home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _662c49f9627f56e1b904931a860d4acf < prev    next >
Encoding:
Text File  |  2001-09-04  |  85.9 KB  |  2,709 lines
  1. package DB;
  2.  
  3. # Debugger for Perl 5.00x; perl5db.pl patch level:
  4.  
  5. $VERSION = 1.07;
  6. $header = "perl5db.pl version $VERSION";
  7.  
  8. #
  9. # This file is automatically included if you do perl -d.
  10. # It's probably not useful to include this yourself.
  11. #
  12. # Perl supplies the values for %sub.  It effectively inserts
  13. # a &DB'DB(); in front of every place that can have a
  14. # breakpoint. Instead of a subroutine call it calls &DB::sub with
  15. # $DB::sub being the called subroutine. It also inserts a BEGIN
  16. # {require 'perl5db.pl'} before the first line.
  17. #
  18. # After each `require'd file is compiled, but before it is executed, a
  19. # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
  20. # $filename is the expanded name of the `require'd file (as found as
  21. # value of %INC).
  22. #
  23. # Additional services from Perl interpreter:
  24. #
  25. # if caller() is called from the package DB, it provides some
  26. # additional data.
  27. #
  28. # The array @{$main::{'_<'.$filename}} is the line-by-line contents of
  29. # $filename.
  30. #
  31. # The hash %{'_<'.$filename} contains breakpoints and action (it is
  32. # keyed by line number), and individual entries are settable (as
  33. # opposed to the whole hash). Only true/false is important to the
  34. # interpreter, though the values used by perl5db.pl have the form
  35. # "$break_condition\0$action". Values are magical in numeric context.
  36. #
  37. # The scalar ${'_<'.$filename} contains $filename.
  38. #
  39. # Note that no subroutine call is possible until &DB::sub is defined
  40. # (for subroutines defined outside of the package DB). In fact the same is
  41. # true if $deep is not defined.
  42. #
  43. # $Log:    perldb.pl,v $
  44.  
  45. #
  46. # At start reads $rcfile that may set important options.  This file
  47. # may define a subroutine &afterinit that will be executed after the
  48. # debugger is initialized.
  49. #
  50. # After $rcfile is read reads environment variable PERLDB_OPTS and parses
  51. # it as a rest of `O ...' line in debugger prompt.
  52. #
  53. # The options that can be specified only at startup:
  54. # [To set in $rcfile, call &parse_options("optionName=new_value").]
  55. #
  56. # TTY  - the TTY to use for debugging i/o.
  57. #
  58. # noTTY - if set, goes in NonStop mode.  On interrupt if TTY is not set
  59. # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
  60. # Term::Rendezvous.  Current variant is to have the name of TTY in this
  61. # file.
  62. #
  63. # ReadLine - If false, dummy ReadLine is used, so you can debug
  64. # ReadLine applications.
  65. #
  66. # NonStop - if true, no i/o is performed until interrupt.
  67. #
  68. # LineInfo - file or pipe to print line number info to.  If it is a
  69. # pipe, a short "emacs like" message is used.
  70. #
  71. # RemotePort - host:port to connect to on remote host for remote debugging.
  72. #
  73. # Example $rcfile: (delete leading hashes!)
  74. #
  75. # &parse_options("NonStop=1 LineInfo=db.out");
  76. # sub afterinit { $trace = 1; }
  77. #
  78. # The script will run without human intervention, putting trace
  79. # information into db.out.  (If you interrupt it, you would better
  80. # reset LineInfo to something "interactive"!)
  81. #
  82. ##################################################################
  83.  
  84. # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
  85. # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
  86.  
  87. # modified Perl debugger, to be run from Emacs in perldb-mode
  88. # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
  89. # Johan Vromans -- upgrade to 4.0 pl 10
  90. # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
  91.  
  92. # Changelog:
  93.  
  94. # A lot of things changed after 0.94. First of all, core now informs
  95. # debugger about entry into XSUBs, overloaded operators, tied operations,
  96. # BEGIN and END. Handy with `O f=2'.
  97.  
  98. # This can make debugger a little bit too verbose, please be patient
  99. # and report your problems promptly.
  100.  
  101. # Now the option frame has 3 values: 0,1,2.
  102.  
  103. # Note that if DESTROY returns a reference to the object (or object),
  104. # the deletion of data may be postponed until the next function call,
  105. # due to the need to examine the return value.
  106.  
  107. # Changes: 0.95: `v' command shows versions.
  108. # Changes: 0.96: `v' command shows version of readline.
  109. #    primitive completion works (dynamic variables, subs for `b' and `l',
  110. #        options). Can `p %var'
  111. #    Better help (`h <' now works). New commands <<, >>, {, {{.
  112. #    {dump|print}_trace() coded (to be able to do it from <<cmd).
  113. #    `c sub' documented.
  114. #    At last enough magic combined to stop after the end of debuggee.
  115. #    !! should work now (thanks to Emacs bracket matching an extra
  116. #    `]' in a regexp is caught).
  117. #    `L', `D' and `A' span files now (as documented).
  118. #    Breakpoints in `require'd code are possible (used in `R').
  119. #    Some additional words on internal work of debugger.
  120. #    `b load filename' implemented.
  121. #    `b postpone subr' implemented.
  122. #    now only `q' exits debugger (overwriteable on $inhibit_exit).
  123. #    When restarting debugger breakpoints/actions persist.
  124. #     Buglet: When restarting debugger only one breakpoint/action per 
  125. #        autoloaded function persists.
  126. # Changes: 0.97: NonStop will not stop in at_exit().
  127. #    Option AutoTrace implemented.
  128. #    Trace printed differently if frames are printed too.
  129. #    new `inhibitExit' option.
  130. #    printing of a very long statement interruptible.
  131. # Changes: 0.98: New command `m' for printing possible methods
  132. #    'l -' is a synonim for `-'.
  133. #    Cosmetic bugs in printing stack trace.
  134. #    `frame' & 8 to print "expanded args" in stack trace.
  135. #    Can list/break in imported subs.
  136. #    new `maxTraceLen' option.
  137. #    frame & 4 and frame & 8 granted.
  138. #    new command `m'
  139. #    nonstoppable lines do not have `:' near the line number.
  140. #    `b compile subname' implemented.
  141. #    Will not use $` any more.
  142. #    `-' behaves sane now.
  143. # Changes: 0.99: Completion for `f', `m'.
  144. #    `m' will remove duplicate names instead of duplicate functions.
  145. #    `b load' strips trailing whitespace.
  146. #    completion ignores leading `|'; takes into account current package
  147. #    when completing a subroutine name (same for `l').
  148. # Changes: 1.07: Many fixed by tchrist 13-March-2000
  149. #   BUG FIXES:
  150. #   + Added bare mimimal security checks on perldb rc files, plus
  151. #     comments on what else is needed.
  152. #   + Fixed the ornaments that made "|h" completely unusable.
  153. #     They are not used in print_help if they will hurt.  Strip pod
  154. #     if we're paging to less.
  155. #   + Fixed mis-formatting of help messages caused by ornaments
  156. #     to restore Larry's original formatting.  
  157. #   + Fixed many other formatting errors.  The code is still suboptimal, 
  158. #     and needs a lot of work at restructuing. It's also misindented
  159. #     in many places.
  160. #   + Fixed bug where trying to look at an option like your pager
  161. #     shows "1".  
  162. #   + Fixed some $? processing.  Note: if you use csh or tcsh, you will
  163. #     lose.  You should consider shell escapes not using their shell,
  164. #     or else not caring about detailed status.  This should really be
  165. #     unified into one place, too.
  166. #   + Fixed bug where invisible trailing whitespace on commands hoses you,
  167. #     tricking Perl into thinking you wern't calling a debugger command!
  168. #   + Fixed bug where leading whitespace on commands hoses you.  (One
  169. #     suggests a leading semicolon or any other irrelevant non-whitespace
  170. #     to indicate literal Perl code.)
  171. #   + Fixed bugs that ate warnings due to wrong selected handle.
  172. #   + Fixed a precedence bug on signal stuff.
  173. #   + Fixed some unseemly wording.
  174. #   + Fixed bug in help command trying to call perl method code.
  175. #   + Fixed to call dumpvar from exception handler.  SIGPIPE killed us.
  176. #   ENHANCEMENTS:
  177. #   + Added some comments.  This code is still nasty spaghetti.
  178. #   + Added message if you clear your pre/post command stacks which was
  179. #     very easy to do if you just typed a bare >, <, or {.  (A command
  180. #     without an argument should *never* be a destructive action; this
  181. #     API is fundamentally screwed up; likewise option setting, which
  182. #     is equally buggered.)
  183. #   + Added command stack dump on argument of "?" for >, <, or {.
  184. #   + Added a semi-built-in doc viewer command that calls man with the
  185. #     proper %Config::Config path (and thus gets caching, man -k, etc),
  186. #     or else perldoc on obstreperous platforms.
  187. #   + Added to and rearranged the help information.
  188. #   + Detected apparent misuse of { ... } to declare a block; this used
  189. #     to work but now is a command, and mysteriously gave no complaint.
  190.  
  191. ####################################################################
  192.  
  193. # Needed for the statement after exec():
  194.  
  195. BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
  196. local($^W) = 0;            # Switch run-time warnings off during init.
  197. warn (            # Do not ;-)
  198.       $dumpvar::hashDepth,     
  199.       $dumpvar::arrayDepth,    
  200.       $dumpvar::dumpDBFiles,   
  201.       $dumpvar::dumpPackages,  
  202.       $dumpvar::quoteHighBit,  
  203.       $dumpvar::printUndef,    
  204.       $dumpvar::globPrint,     
  205.       $dumpvar::usageOnly,
  206.       @ARGS,
  207.       $Carp::CarpLevel,
  208.       $panic,
  209.       $second_time,
  210.      ) if 0;
  211.  
  212. # Command-line + PERLLIB:
  213. @ini_INC = @INC;
  214.  
  215. # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
  216.  
  217. $trace = $signal = $single = 0;    # Uninitialized warning suppression
  218.                                 # (local $^W cannot help - other packages!).
  219. $inhibit_exit = $option{PrintRet} = 1;
  220.  
  221. @options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
  222.           compactDump veryCompact quote HighBit undefPrint
  223.           globPrint PrintRet UsageOnly frame AutoTrace
  224.           TTY noTTY ReadLine NonStop LineInfo maxTraceLen
  225.           recallCommand ShellBang pager tkRunning ornaments
  226.           signalLevel warnLevel dieLevel inhibit_exit
  227.           ImmediateStop bareStringify
  228.           RemotePort);
  229.  
  230. %optionVars    = (
  231.          hashDepth    => \$dumpvar::hashDepth,
  232.          arrayDepth    => \$dumpvar::arrayDepth,
  233.          DumpDBFiles    => \$dumpvar::dumpDBFiles,
  234.          DumpPackages    => \$dumpvar::dumpPackages,
  235.          DumpReused    => \$dumpvar::dumpReused,
  236.          HighBit    => \$dumpvar::quoteHighBit,
  237.          undefPrint    => \$dumpvar::printUndef,
  238.          globPrint    => \$dumpvar::globPrint,
  239.          UsageOnly    => \$dumpvar::usageOnly,     
  240.          bareStringify    => \$dumpvar::bareStringify,
  241.          frame          => \$frame,
  242.          AutoTrace      => \$trace,
  243.          inhibit_exit   => \$inhibit_exit,
  244.          maxTraceLen    => \$maxtrace,
  245.          ImmediateStop    => \$ImmediateStop,
  246.          RemotePort    => \$remoteport,
  247. );
  248.  
  249. %optionAction  = (
  250.           compactDump    => \&dumpvar::compactDump,
  251.           veryCompact    => \&dumpvar::veryCompact,
  252.           quote        => \&dumpvar::quote,
  253.           TTY        => \&TTY,
  254.           noTTY        => \&noTTY,
  255.           ReadLine    => \&ReadLine,
  256.           NonStop    => \&NonStop,
  257.           LineInfo    => \&LineInfo,
  258.           recallCommand    => \&recallCommand,
  259.           ShellBang    => \&shellBang,
  260.           pager        => \&pager,
  261.           signalLevel    => \&signalLevel,
  262.           warnLevel    => \&warnLevel,
  263.           dieLevel    => \&dieLevel,
  264.           tkRunning    => \&tkRunning,
  265.           ornaments    => \&ornaments,
  266.           RemotePort    => \&RemotePort,
  267.          );
  268.  
  269. %optionRequire = (
  270.           compactDump    => 'dumpvar.pl',
  271.           veryCompact    => 'dumpvar.pl',
  272.           quote        => 'dumpvar.pl',
  273.          );
  274.  
  275. # These guys may be defined in $ENV{PERL5DB} :
  276. $rl        = 1    unless defined $rl;
  277. $warnLevel    = 0    unless defined $warnLevel;
  278. $dieLevel    = 0    unless defined $dieLevel;
  279. $signalLevel    = 1    unless defined $signalLevel;
  280. $pre        = []    unless defined $pre;
  281. $post        = []    unless defined $post;
  282. $pretype    = []    unless defined $pretype;
  283.  
  284. warnLevel($warnLevel);
  285. dieLevel($dieLevel);
  286. signalLevel($signalLevel);
  287.  
  288. &pager(
  289.     (defined($ENV{PAGER}) 
  290.     ? $ENV{PAGER}
  291.     : ($^O eq 'os2' 
  292.        ? 'cmd /c more' 
  293.        : 'more'))) unless defined $pager;
  294. setman();
  295. &recallCommand("!") unless defined $prc;
  296. &shellBang("!") unless defined $psh;
  297. $maxtrace = 400 unless defined $maxtrace;
  298.  
  299. if (-e "/dev/tty") {  # this is the wrong metric!
  300.   $rcfile=".perldb";
  301. } else {
  302.   $rcfile="perldb.ini";
  303. }
  304.  
  305. # This isn't really safe, because there's a race
  306. # between checking and opening.  The solution is to
  307. # open and fstat the handle, but then you have to read and
  308. # eval the contents.  But then the silly thing gets
  309. # your lexical scope, which is unfortunately at best.
  310. sub safe_do { 
  311.     my $file = shift;
  312.  
  313.     # Just exactly what part of the word "CORE::" don't you understand?
  314.     local $SIG{__WARN__};  
  315.     local $SIG{__DIE__};    
  316.  
  317.     unless (is_safe_file($file)) {
  318.     CORE::warn <<EO_GRIPE;
  319. perldb: Must not source insecure rcfile $file.
  320.         You or the superuser must be the owner, and it must not 
  321.     be writable by anyone but its owner.
  322. EO_GRIPE
  323.     return;
  324.     } 
  325.  
  326.     do $file;
  327.     CORE::warn("perldb: couldn't parse $file: $@") if $@;
  328. }
  329.  
  330.  
  331. # Verifies that owner is either real user or superuser and that no
  332. # one but owner may write to it.  This function is of limited use
  333. # when called on a path instead of upon a handle, because there are
  334. # no guarantees that filename (by dirent) whose file (by ino) is
  335. # eventually accessed is the same as the one tested. 
  336. # Assumes that the file's existence is not in doubt.
  337. sub is_safe_file {
  338.     my $path = shift;
  339.     stat($path) || return;    # mysteriously vaporized
  340.     my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
  341.  
  342.     return 0 if $uid != 0 && $uid != $<;
  343.     return 0 if $mode & 022;
  344.     return 1;
  345. }
  346.  
  347. if (-f $rcfile) {
  348.     safe_do("./$rcfile");
  349. } 
  350. elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
  351.     safe_do("$ENV{HOME}/$rcfile");
  352. }
  353. elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
  354.     safe_do("$ENV{LOGDIR}/$rcfile");
  355. }
  356.  
  357. if (defined $ENV{PERLDB_OPTS}) {
  358.   parse_options($ENV{PERLDB_OPTS});
  359. }
  360.  
  361. # Here begin the unreadable code.  It needs fixing.
  362.  
  363. if (exists $ENV{PERLDB_RESTART}) {
  364.   delete $ENV{PERLDB_RESTART};
  365.   # $restart = 1;
  366.   @hist = get_list('PERLDB_HIST');
  367.   %break_on_load = get_list("PERLDB_ON_LOAD");
  368.   %postponed = get_list("PERLDB_POSTPONE");
  369.   my @had_breakpoints= get_list("PERLDB_VISITED");
  370.   for (0 .. $#had_breakpoints) {
  371.     my %pf = get_list("PERLDB_FILE_$_");
  372.     $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
  373.   }
  374.   my %opt = get_list("PERLDB_OPT");
  375.   my ($opt,$val);
  376.   while (($opt,$val) = each %opt) {
  377.     $val =~ s/[\\\']/\\$1/g;
  378.     parse_options("$opt'$val'");
  379.   }
  380.   @INC = get_list("PERLDB_INC");
  381.   @ini_INC = @INC;
  382.   $pretype = [get_list("PERLDB_PRETYPE")];
  383.   $pre = [get_list("PERLDB_PRE")];
  384.   $post = [get_list("PERLDB_POST")];
  385.   @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
  386. }
  387.  
  388. if ($notty) {
  389.   $runnonstop = 1;
  390. } else {
  391.   # Is Perl being run from a slave editor or graphical debugger?
  392.   $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
  393.   $rl = 0, shift(@main::ARGV) if $slave_editor;
  394.  
  395.   #require Term::ReadLine;
  396.  
  397.   if ($^O eq 'cygwin') {
  398.     # /dev/tty is binary. use stdin for textmode
  399.     undef $console;
  400.   } elsif (-e "/dev/tty") {
  401.     $console = "/dev/tty";
  402.   } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
  403.     $console = "con";
  404.   } elsif ($^O eq 'MacOS') {
  405.     if ($MacPerl::Version !~ /MPW/) {
  406.       $console = "Dev:Console:Perl Debug"; # Separate window for application
  407.     } else {
  408.       $console = "Dev:Console";
  409.     }
  410.   } else {
  411.     $console = "sys\$command";
  412.   }
  413.  
  414.   if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
  415.     $console = undef;
  416.   }
  417.  
  418.   # Around a bug:
  419.   if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
  420.     $console = undef;
  421.   }
  422.  
  423.   if ($^O eq 'epoc') {
  424.     $console = undef;
  425.   }
  426.  
  427.   $console = $tty if defined $tty;
  428.  
  429.   if (defined $remoteport) {
  430.     require IO::Socket;
  431.     $OUT = new IO::Socket::INET( Timeout  => '10',
  432.                                  PeerAddr => $remoteport,
  433.                                  Proto    => 'tcp',
  434.                                );
  435.     if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
  436.     $IN = $OUT;
  437.   }
  438.   else {
  439.     if (defined $console) {
  440.       open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
  441.       open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
  442.         || open(OUT,">&STDOUT");    # so we don't dongle stdout
  443.     } else {
  444.       open(IN,"<&STDIN");
  445.       open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
  446.       $console = 'STDIN/OUT';
  447.     }
  448.     # so open("|more") can read from STDOUT and so we don't dingle stdin
  449.     $IN = \*IN;
  450.  
  451.     $OUT = \*OUT;
  452.   }
  453.   select($OUT);
  454.   $| = 1;            # for DB::OUT
  455.   select(STDOUT);
  456.  
  457.   $LINEINFO = $OUT unless defined $LINEINFO;
  458.   $lineinfo = $console unless defined $lineinfo;
  459.  
  460.   $| = 1;            # for real STDOUT
  461.  
  462.   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
  463.   unless ($runnonstop) {
  464.     print $OUT "\nLoading DB routines from $header\n";
  465.     print $OUT ("Editor support ",
  466.         $slave_editor ? "enabled" : "available",
  467.         ".\n");
  468.     print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
  469.   }
  470. }
  471.  
  472. @ARGS = @ARGV;
  473. for (@args) {
  474.     s/\'/\\\'/g;
  475.     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  476. }
  477.  
  478. if (defined &afterinit) {    # May be defined in $rcfile
  479.   &afterinit();
  480. }
  481.  
  482. $I_m_init = 1;
  483.  
  484. ############################################################ Subroutines
  485.  
  486. sub DB {
  487.     # _After_ the perl program is compiled, $single is set to 1:
  488.     if ($single and not $second_time++) {
  489.       if ($runnonstop) {    # Disable until signal
  490.     for ($i=0; $i <= $stack_depth; ) {
  491.         $stack[$i++] &= ~1;
  492.     }
  493.     $single = 0;
  494.     # return;            # Would not print trace!
  495.       } elsif ($ImmediateStop) {
  496.     $ImmediateStop = 0;
  497.     $signal = 1;
  498.       }
  499.     }
  500.     $runnonstop = 0 if $single or $signal; # Disable it if interactive.
  501.     &save;
  502.     ($package, $filename, $line) = caller;
  503.     $filename_ini = $filename;
  504.     $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
  505.       "package $package;";    # this won't let them modify, alas
  506.     local(*dbline) = $main::{'_<' . $filename};
  507.     $max = $#dbline;
  508.     if (($stop,$action) = split(/\0/,$dbline{$line})) {
  509.     if ($stop eq '1') {
  510.         $signal |= 1;
  511.     } elsif ($stop) {
  512.         $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
  513.         $dbline{$line} =~ s/;9($|\0)/$1/;
  514.     }
  515.     }
  516.     my $was_signal = $signal;
  517.     if ($trace & 2) {
  518.       for (my $n = 0; $n <= $#to_watch; $n++) {
  519.     $evalarg = $to_watch[$n];
  520.     local $onetimeDump;    # Do not output results
  521.     my ($val) = &eval;    # Fix context (&eval is doing array)?
  522.     $val = ( (defined $val) ? "'$val'" : 'undef' );
  523.     if ($val ne $old_watch[$n]) {
  524.       $signal = 1;
  525.       print $OUT <<EOP;
  526. Watchpoint $n:\t$to_watch[$n] changed:
  527.     old value:\t$old_watch[$n]
  528.     new value:\t$val
  529. EOP
  530.       $old_watch[$n] = $val;
  531.     }
  532.       }
  533.     }
  534.     if ($trace & 4) {        # User-installed watch
  535.       return if watchfunction($package, $filename, $line) 
  536.     and not $single and not $was_signal and not ($trace & ~4);
  537.     }
  538.     $was_signal = $signal;
  539.     $signal = 0;
  540.     if ($single || ($trace & 1) || $was_signal) {
  541.     if ($slave_editor) {
  542.         $position = "\032\032$filename:$line:0\n";
  543.         print $LINEINFO $position;
  544.     } elsif ($package eq 'DB::fake') {
  545.       $term || &setterm;
  546.       print_help(<<EOP);
  547. Debugged program terminated.  Use B<q> to quit or B<R> to restart,
  548.   use B<O> I<inhibit_exit> to avoid stopping after program termination,
  549.   B<h q>, B<h R> or B<h O> to get additional info.  
  550. EOP
  551.       $package = 'main';
  552.       $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
  553.         "package $package;";    # this won't let them modify, alas
  554.     } else {
  555.         $sub =~ s/\'/::/;
  556.         $prefix = $sub =~ /::/ ? "" : "${'package'}::";
  557.         $prefix .= "$sub($filename:";
  558.         $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
  559.         if (length($prefix) > 30) {
  560.             $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
  561.         $prefix = "";
  562.         $infix = ":\t";
  563.         } else {
  564.         $infix = "):\t";
  565.         $position = "$prefix$line$infix$dbline[$line]$after";
  566.         }
  567.         if ($frame) {
  568.         print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after";
  569.         } else {
  570.         print $LINEINFO $position;
  571.         }
  572.         for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
  573.         last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
  574.         last if $signal;
  575.         $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
  576.         $incr_pos = "$prefix$i$infix$dbline[$i]$after";
  577.         $position .= $incr_pos;
  578.         if ($frame) {
  579.             print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after";
  580.         } else {
  581.             print $LINEINFO $incr_pos;
  582.         }
  583.         }
  584.     }
  585.     }
  586.     $evalarg = $action, &eval if $action;
  587.     if ($single || $was_signal) {
  588.     local $level = $level + 1;
  589.     foreach $evalarg (@$pre) {
  590.       &eval;
  591.     }
  592.     print $OUT $stack_depth . " levels deep in subroutine calls!\n"
  593.       if $single & 4;
  594.     $start = $line;
  595.     $incr = -1;        # for backward motion.
  596.     @typeahead = (@$pretype, @typeahead);
  597.       CMD:
  598.     while (($term || &setterm),
  599.            ($term_pid == $$ or &resetterm),
  600.            defined ($cmd=&readline("  DB" . ('<' x $level) .
  601.                        ($#hist+1) . ('>' x $level) .
  602.                        " "))) 
  603.         {
  604.         $single = 0;
  605.         $signal = 0;
  606.         $cmd =~ s/\\$/\n/ && do {
  607.             $cmd .= &readline("  cont: ");
  608.             redo CMD;
  609.         };
  610.         $cmd =~ /^$/ && ($cmd = $laststep);
  611.         push(@hist,$cmd) if length($cmd) > 1;
  612.           PIPE: {
  613.             $cmd =~ s/^\s+//s;   # trim annoying leading whitespace
  614.             $cmd =~ s/\s+$//s;   # trim annoying trailing whitespace
  615.             ($i) = split(/\s+/,$cmd);
  616.             if ($alias{$i}) { 
  617.             # squelch the sigmangler
  618.             local $SIG{__DIE__};
  619.             local $SIG{__WARN__};
  620.             eval "\$cmd =~ $alias{$i}";
  621.             if ($@) {
  622.                 print $OUT "Couldn't evaluate `$i' alias: $@";
  623.                 next CMD;
  624.             } 
  625.             }
  626.                    $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?;
  627.             $cmd =~ /^h$/ && do {
  628.             print_help($help);
  629.             next CMD; };
  630.             $cmd =~ /^h\s+h$/ && do {
  631.             print_help($summary);
  632.             next CMD; };
  633.             # support long commands; otherwise bogus errors
  634.             # happen when you ask for h on <CR> for example
  635.             $cmd =~ /^h\s+(\S.*)$/ && do {      
  636.             my $asked = $1;            # for proper errmsg
  637.             my $qasked = quotemeta($asked); # for searching
  638.             # XXX: finds CR but not <CR>
  639.             if ($help =~ /^<?(?:[IB]<)$qasked/m) {
  640.               while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
  641.                 print_help($1);
  642.               }
  643.             } else {
  644.                 print_help("B<$asked> is not a debugger command.\n");
  645.             }
  646.             next CMD; };
  647.             $cmd =~ /^t$/ && do {
  648.             $trace ^= 1;
  649.             print $OUT "Trace = " .
  650.                 (($trace & 1) ? "on" : "off" ) . "\n";
  651.             next CMD; };
  652.             $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
  653.             $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
  654.             foreach $subname (sort(keys %sub)) {
  655.                 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
  656.                 print $OUT $subname,"\n";
  657.                 }
  658.             }
  659.             next CMD; };
  660.             $cmd =~ /^v$/ && do {
  661.             list_versions(); next CMD};
  662.             $cmd =~ s/^X\b/V $package/;
  663.             $cmd =~ /^V$/ && do {
  664.             $cmd = "V $package"; };
  665.             $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
  666.             local ($savout) = select($OUT);
  667.             $packname = $1;
  668.             @vars = split(' ',$2);
  669.             do 'dumpvar.pl' unless defined &main::dumpvar;
  670.             if (defined &main::dumpvar) {
  671.                 local $frame = 0;
  672.                 local $doret = -2;
  673.                 # must detect sigpipe failures
  674.                 eval { &main::dumpvar($packname,@vars) };
  675.                 if ($@) {
  676.                 die unless $@ =~ /dumpvar print failed/;
  677.                 } 
  678.             } else {
  679.                 print $OUT "dumpvar.pl not available.\n";
  680.             }
  681.             select ($savout);
  682.             next CMD; };
  683.             $cmd =~ s/^x\b/ / && do { # So that will be evaled
  684.             $onetimeDump = 'dump'; };
  685.             $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
  686.             methods($1); next CMD};
  687.             $cmd =~ s/^m\b/ / && do { # So this will be evaled
  688.             $onetimeDump = 'methods'; };
  689.             $cmd =~ /^f\b\s*(.*)/ && do {
  690.             $file = $1;
  691.             $file =~ s/\s+$//;
  692.             if (!$file) {
  693.                 print $OUT "The old f command is now the r command.\n";
  694.                 print $OUT "The new f command switches filenames.\n";
  695.                 next CMD;
  696.             }
  697.             if (!defined $main::{'_<' . $file}) {
  698.                 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
  699.                           $try = substr($try,2);
  700.                           print $OUT "Choosing $try matching `$file':\n";
  701.                           $file = $try;
  702.                       }}
  703.             }
  704.             if (!defined $main::{'_<' . $file}) {
  705.                 print $OUT "No file matching `$file' is loaded.\n";
  706.                 next CMD;
  707.             } elsif ($file ne $filename) {
  708.                 *dbline = $main::{'_<' . $file};
  709.                 $max = $#dbline;
  710.                 $filename = $file;
  711.                 $start = 1;
  712.                 $cmd = "l";
  713.               } else {
  714.                 print $OUT "Already in $file.\n";
  715.                 next CMD;
  716.               }
  717.               };
  718.             $cmd =~ s/^l\s+-\s*$/-/;
  719.             $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
  720.             $evalarg = $2;
  721.             my ($s) = &eval;
  722.             print($OUT "Error: $@\n"), next CMD if $@;
  723.             $s = CvGV_name($s);
  724.             print($OUT "Interpreted as: $1 $s\n");
  725.             $cmd = "$1 $s";
  726.             };
  727.             $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
  728.             $subname = $1;
  729.             $subname =~ s/\'/::/;
  730.             $subname = $package."::".$subname 
  731.               unless $subname =~ /::/;
  732.             $subname = "main".$subname if substr($subname,0,2) eq "::";
  733.             @pieces = split(/:/,find_sub($subname) || $sub{$subname});
  734.             $subrange = pop @pieces;
  735.             $file = join(':', @pieces);
  736.             if ($file ne $filename) {
  737.                 print $OUT "Switching to file '$file'.\n"
  738.                 unless $slave_editor;
  739.                 *dbline = $main::{'_<' . $file};
  740.                 $max = $#dbline;
  741.                 $filename = $file;
  742.             }
  743.             if ($subrange) {
  744.                 if (eval($subrange) < -$window) {
  745.                 $subrange =~ s/-.*/+/;
  746.                 }
  747.                 $cmd = "l $subrange";
  748.             } else {
  749.                 print $OUT "Subroutine $subname not found.\n";
  750.                 next CMD;
  751.             } };
  752.             $cmd =~ /^\.$/ && do {
  753.             $incr = -1;        # for backward motion.
  754.             $start = $line;
  755.             $filename = $filename_ini;
  756.             *dbline = $main::{'_<' . $filename};
  757.             $max = $#dbline;
  758.             print $LINEINFO $position;
  759.             next CMD };
  760.             $cmd =~ /^w\b\s*(\d*)$/ && do {
  761.             $incr = $window - 1;
  762.             $start = $1 if $1;
  763.             $start -= $preview;
  764.             #print $OUT 'l ' . $start . '-' . ($start + $incr);
  765.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  766.             $cmd =~ /^-$/ && do {
  767.             $start -= $incr + $window + 1;
  768.             $start = 1 if $start <= 0;
  769.             $incr = $window - 1;
  770.             $cmd = 'l ' . ($start) . '+'; };
  771.             $cmd =~ /^l$/ && do {
  772.             $incr = $window - 1;
  773.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  774.             $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
  775.             $start = $1 if $1;
  776.             $incr = $2;
  777.             $incr = $window - 1 unless $incr;
  778.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  779.             $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
  780.             $end = (!defined $2) ? $max : ($4 ? $4 : $2);
  781.             $end = $max if $end > $max;
  782.             $i = $2;
  783.             $i = $line if $i eq '.';
  784.             $i = 1 if $i < 1;
  785.             $incr = $end - $i;
  786.             if ($slave_editor) {
  787.                 print $OUT "\032\032$filename:$i:0\n";
  788.                 $i = $end;
  789.             } else {
  790.                 for (; $i <= $end; $i++) {
  791.                     ($stop,$action) = split(/\0/, $dbline{$i});
  792.                     $arrow = ($i==$line 
  793.                       and $filename eq $filename_ini) 
  794.                   ?  '==>' 
  795.                     : ($dbline[$i]+0 ? ':' : ' ') ;
  796.                 $arrow .= 'b' if $stop;
  797.                 $arrow .= 'a' if $action;
  798.                 print $OUT "$i$arrow\t", $dbline[$i];
  799.                 $i++, last if $signal;
  800.                 }
  801.                 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
  802.             }
  803.             $start = $i; # remember in case they want more
  804.             $start = $max if $start > $max;
  805.             next CMD; };
  806.             $cmd =~ /^D$/ && do {
  807.               print $OUT "Deleting all breakpoints...\n";
  808.               my $file;
  809.               for $file (keys %had_breakpoints) {
  810.             local *dbline = $main::{'_<' . $file};
  811.             my $max = $#dbline;
  812.             my $was;
  813.             
  814.             for ($i = 1; $i <= $max ; $i++) {
  815.                 if (defined $dbline{$i}) {
  816.                 $dbline{$i} =~ s/^[^\0]+//;
  817.                 if ($dbline{$i} =~ s/^\0?$//) {
  818.                     delete $dbline{$i};
  819.                 }
  820.                 }
  821.             }
  822.             
  823.             if (not $had_breakpoints{$file} &= ~1) {
  824.                 delete $had_breakpoints{$file};
  825.             }
  826.               }
  827.               undef %postponed;
  828.               undef %postponed_file;
  829.               undef %break_on_load;
  830.               next CMD; };
  831.             $cmd =~ /^L$/ && do {
  832.               my $file;
  833.               for $file (keys %had_breakpoints) {
  834.             local *dbline = $main::{'_<' . $file};
  835.             my $max = $#dbline;
  836.             my $was;
  837.             
  838.             for ($i = 1; $i <= $max; $i++) {
  839.                 if (defined $dbline{$i}) {
  840.                     print $OUT "$file:\n" unless $was++;
  841.                 print $OUT " $i:\t", $dbline[$i];
  842.                 ($stop,$action) = split(/\0/, $dbline{$i});
  843.                 print $OUT "   break if (", $stop, ")\n"
  844.                   if $stop;
  845.                 print $OUT "   action:  ", $action, "\n"
  846.                   if $action;
  847.                 last if $signal;
  848.                 }
  849.             }
  850.               }
  851.               if (%postponed) {
  852.             print $OUT "Postponed breakpoints in subroutines:\n";
  853.             my $subname;
  854.             for $subname (keys %postponed) {
  855.               print $OUT " $subname\t$postponed{$subname}\n";
  856.               last if $signal;
  857.             }
  858.               }
  859.               my @have = map { # Combined keys
  860.             keys %{$postponed_file{$_}}
  861.               } keys %postponed_file;
  862.               if (@have) {
  863.             print $OUT "Postponed breakpoints in files:\n";
  864.             my ($file, $line);
  865.             for $file (keys %postponed_file) {
  866.               my $db = $postponed_file{$file};
  867.               print $OUT " $file:\n";
  868.               for $line (sort {$a <=> $b} keys %$db) {
  869.                 print $OUT "  $line:\n";
  870.                 my ($stop,$action) = split(/\0/, $$db{$line});
  871.                 print $OUT "    break if (", $stop, ")\n"
  872.                   if $stop;
  873.                 print $OUT "    action:  ", $action, "\n"
  874.                   if $action;
  875.                 last if $signal;
  876.               }
  877.               last if $signal;
  878.             }
  879.               }
  880.               if (%break_on_load) {
  881.             print $OUT "Breakpoints on load:\n";
  882.             my $file;
  883.             for $file (keys %break_on_load) {
  884.               print $OUT " $file\n";
  885.               last if $signal;
  886.             }
  887.               }
  888.               if ($trace & 2) {
  889.             print $OUT "Watch-expressions:\n";
  890.             my $expr;
  891.             for $expr (@to_watch) {
  892.               print $OUT " $expr\n";
  893.               last if $signal;
  894.             }
  895.               }
  896.               next CMD; };
  897.             $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
  898.             my $file = $1; $file =~ s/\s+$//;
  899.             {
  900.               $break_on_load{$file} = 1;
  901.               $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
  902.               $file .= '.pm', redo unless $file =~ /\./;
  903.             }
  904.             $had_breakpoints{$file} |= 1;
  905.             print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
  906.             next CMD; };
  907.             $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
  908.             my $cond = length $3 ? $3 : '1';
  909.             my ($subname, $break) = ($2, $1 eq 'postpone');
  910.             $subname =~ s/\'/::/g;
  911.             $subname = "${'package'}::" . $subname
  912.               unless $subname =~ /::/;
  913.             $subname = "main".$subname if substr($subname,0,2) eq "::";
  914.             $postponed{$subname} = $break 
  915.               ? "break +0 if $cond" : "compile";
  916.             next CMD; };
  917.             $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
  918.             $subname = $1;
  919.             $cond = length $2 ? $2 : '1';
  920.             $subname =~ s/\'/::/g;
  921.             $subname = "${'package'}::" . $subname
  922.               unless $subname =~ /::/;
  923.             $subname = "main".$subname if substr($subname,0,2) eq "::";
  924.             # Filename below can contain ':'
  925.             ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
  926.             $i += 0;
  927.             if ($i) {
  928.                 local $filename = $file;
  929.                 local *dbline = $main::{'_<' . $filename};
  930.                 $had_breakpoints{$filename} |= 1;
  931.                 $max = $#dbline;
  932.                 ++$i while $dbline[$i] == 0 && $i < $max;
  933.                 $dbline{$i} =~ s/^[^\0]*/$cond/;
  934.             } else {
  935.                 print $OUT "Subroutine $subname not found.\n";
  936.             }
  937.             next CMD; };
  938.             $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
  939.             $i = $1 || $line;
  940.             $cond = length $2 ? $2 : '1';
  941.             if ($dbline[$i] == 0) {
  942.                 print $OUT "Line $i not breakable.\n";
  943.             } else {
  944.                 $had_breakpoints{$filename} |= 1;
  945.                 $dbline{$i} =~ s/^[^\0]*/$cond/;
  946.             }
  947.             next CMD; };
  948.             $cmd =~ /^d\b\s*(\d*)/ && do {
  949.             $i = $1 || $line;
  950.                         if ($dbline[$i] == 0) {
  951.                             print $OUT "Line $i not breakable.\n";
  952.                         } else {
  953.                 $dbline{$i} =~ s/^[^\0]*//;
  954.                 delete $dbline{$i} if $dbline{$i} eq '';
  955.                         }
  956.             next CMD; };
  957.             $cmd =~ /^A$/ && do {
  958.               print $OUT "Deleting all actions...\n";
  959.               my $file;
  960.               for $file (keys %had_breakpoints) {
  961.             local *dbline = $main::{'_<' . $file};
  962.             my $max = $#dbline;
  963.             my $was;
  964.             
  965.             for ($i = 1; $i <= $max ; $i++) {
  966.                 if (defined $dbline{$i}) {
  967.                 $dbline{$i} =~ s/\0[^\0]*//;
  968.                 delete $dbline{$i} if $dbline{$i} eq '';
  969.                 }
  970.             }
  971.             
  972.             unless ($had_breakpoints{$file} &= ~2) {
  973.                 delete $had_breakpoints{$file};
  974.             }
  975.               }
  976.               next CMD; };
  977.             $cmd =~ /^O\s*$/ && do {
  978.             for (@options) {
  979.                 &dump_option($_);
  980.             }
  981.             next CMD; };
  982.             $cmd =~ /^O\s*(\S.*)/ && do {
  983.             parse_options($1);
  984.             next CMD; };
  985.             $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
  986.             push @$pre, action($1);
  987.             next CMD; };
  988.             $cmd =~ /^>>\s*(.*)/ && do {
  989.             push @$post, action($1);
  990.             next CMD; };
  991.             $cmd =~ /^<\s*(.*)/ && do {
  992.             unless ($1) {
  993.                 print $OUT "All < actions cleared.\n";
  994.                 $pre = [];
  995.                 next CMD;
  996.             } 
  997.             if ($1 eq '?') {
  998.                 unless (@$pre) {
  999.                 print $OUT "No pre-prompt Perl actions.\n";
  1000.                 next CMD;
  1001.                 } 
  1002.                 print $OUT "Perl commands run before each prompt:\n";
  1003.                 for my $action ( @$pre ) {
  1004.                 print $OUT "\t< -- $action\n";
  1005.                 } 
  1006.                 next CMD;
  1007.             } 
  1008.             $pre = [action($1)];
  1009.             next CMD; };
  1010.             $cmd =~ /^>\s*(.*)/ && do {
  1011.             unless ($1) {
  1012.                 print $OUT "All > actions cleared.\n";
  1013.                 $post = [];
  1014.                 next CMD;
  1015.             }
  1016.             if ($1 eq '?') {
  1017.                 unless (@$post) {
  1018.                 print $OUT "No post-prompt Perl actions.\n";
  1019.                 next CMD;
  1020.                 } 
  1021.                 print $OUT "Perl commands run after each prompt:\n";
  1022.                 for my $action ( @$post ) {
  1023.                 print $OUT "\t> -- $action\n";
  1024.                 } 
  1025.                 next CMD;
  1026.             } 
  1027.             $post = [action($1)];
  1028.             next CMD; };
  1029.             $cmd =~ /^\{\{\s*(.*)/ && do {
  1030.             if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) { 
  1031.                 print $OUT "{{ is now a debugger command\n",
  1032.                 "use `;{{' if you mean Perl code\n";
  1033.                 $cmd = "h {{";
  1034.                 redo CMD;
  1035.             } 
  1036.             push @$pretype, $1;
  1037.             next CMD; };
  1038.             $cmd =~ /^\{\s*(.*)/ && do {
  1039.             unless ($1) {
  1040.                 print $OUT "All { actions cleared.\n";
  1041.                 $pretype = [];
  1042.                 next CMD;
  1043.             }
  1044.             if ($1 eq '?') {
  1045.                 unless (@$pretype) {
  1046.                 print $OUT "No pre-prompt debugger actions.\n";
  1047.                 next CMD;
  1048.                 } 
  1049.                 print $OUT "Debugger commands run before each prompt:\n";
  1050.                 for my $action ( @$pretype ) {
  1051.                 print $OUT "\t{ -- $action\n";
  1052.                 } 
  1053.                 next CMD;
  1054.             } 
  1055.             if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) { 
  1056.                 print $OUT "{ is now a debugger command\n",
  1057.                 "use `;{' if you mean Perl code\n";
  1058.                 $cmd = "h {";
  1059.                 redo CMD;
  1060.             } 
  1061.             $pretype = [$1];
  1062.             next CMD; };
  1063.             $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
  1064.             $i = $1 || $line; $j = $2;
  1065.             if (length $j) {
  1066.                 if ($dbline[$i] == 0) {
  1067.                 print $OUT "Line $i may not have an action.\n";
  1068.                 } else {
  1069.                 $had_breakpoints{$filename} |= 2;
  1070.                 $dbline{$i} =~ s/\0[^\0]*//;
  1071.                 $dbline{$i} .= "\0" . action($j);
  1072.                 }
  1073.             } else {
  1074.                 $dbline{$i} =~ s/\0[^\0]*//;
  1075.                 delete $dbline{$i} if $dbline{$i} eq '';
  1076.             }
  1077.             next CMD; };
  1078.             $cmd =~ /^n$/ && do {
  1079.                 end_report(), next CMD if $finished and $level <= 1;
  1080.             $single = 2;
  1081.             $laststep = $cmd;
  1082.             last CMD; };
  1083.             $cmd =~ /^s$/ && do {
  1084.                 end_report(), next CMD if $finished and $level <= 1;
  1085.             $single = 1;
  1086.             $laststep = $cmd;
  1087.             last CMD; };
  1088.             $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
  1089.                 end_report(), next CMD if $finished and $level <= 1;
  1090.             $subname = $i = $1;
  1091.             #  Probably not needed, since we finish an interactive
  1092.             #  sub-session anyway...
  1093.             # local $filename = $filename;
  1094.             # local *dbline = *dbline;    # XXX Would this work?!
  1095.             if ($i =~ /\D/) { # subroutine name
  1096.                 $subname = $package."::".$subname 
  1097.                     unless $subname =~ /::/;
  1098.                 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
  1099.                 $i += 0;
  1100.                 if ($i) {
  1101.                     $filename = $file;
  1102.                 *dbline = $main::{'_<' . $filename};
  1103.                 $had_breakpoints{$filename} |= 1;
  1104.                 $max = $#dbline;
  1105.                 ++$i while $dbline[$i] == 0 && $i < $max;
  1106.                 } else {
  1107.                 print $OUT "Subroutine $subname not found.\n";
  1108.                 next CMD; 
  1109.                 }
  1110.             }
  1111.             if ($i) {
  1112.                 if ($dbline[$i] == 0) {
  1113.                 print $OUT "Line $i not breakable.\n";
  1114.                 next CMD;
  1115.                 }
  1116.                 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
  1117.             }
  1118.             for ($i=0; $i <= $stack_depth; ) {
  1119.                 $stack[$i++] &= ~1;
  1120.             }
  1121.             last CMD; };
  1122.             $cmd =~ /^r$/ && do {
  1123.                 end_report(), next CMD if $finished and $level <= 1;
  1124.             $stack[$stack_depth] |= 1;
  1125.             $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
  1126.             last CMD; };
  1127.             $cmd =~ /^R$/ && do {
  1128.                 print $OUT "Warning: some settings and command-line options may be lost!\n";
  1129.             my (@script, @flags, $cl);
  1130.             push @flags, '-w' if $ini_warn;
  1131.             # Put all the old includes at the start to get
  1132.             # the same debugger.
  1133.             for (@ini_INC) {
  1134.               push @flags, '-I', $_;
  1135.             }
  1136.             # Arrange for setting the old INC:
  1137.             set_list("PERLDB_INC", @ini_INC);
  1138.             if ($0 eq '-e') {
  1139.               for (1..$#{'::_<-e'}) { # The first line is PERL5DB
  1140.                     chomp ($cl =  ${'::_<-e'}[$_]);
  1141.                 push @script, '-e', $cl;
  1142.               }
  1143.             } else {
  1144.               @script = $0;
  1145.             }
  1146.             set_list("PERLDB_HIST", 
  1147.                  $term->Features->{getHistory} 
  1148.                  ? $term->GetHistory : @hist);
  1149.             my @had_breakpoints = keys %had_breakpoints;
  1150.             set_list("PERLDB_VISITED", @had_breakpoints);
  1151.             set_list("PERLDB_OPT", %option);
  1152.             set_list("PERLDB_ON_LOAD", %break_on_load);
  1153.             my @hard;
  1154.             for (0 .. $#had_breakpoints) {
  1155.               my $file = $had_breakpoints[$_];
  1156.               *dbline = $main::{'_<' . $file};
  1157.               next unless %dbline or $postponed_file{$file};
  1158.               (push @hard, $file), next 
  1159.                 if $file =~ /^\(eval \d+\)$/;
  1160.               my @add;
  1161.               @add = %{$postponed_file{$file}}
  1162.                 if $postponed_file{$file};
  1163.               set_list("PERLDB_FILE_$_", %dbline, @add);
  1164.             }
  1165.             for (@hard) { # Yes, really-really...
  1166.               # Find the subroutines in this eval
  1167.               *dbline = $main::{'_<' . $_};
  1168.               my ($quoted, $sub, %subs, $line) = quotemeta $_;
  1169.               for $sub (keys %sub) {
  1170.                 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
  1171.                 $subs{$sub} = [$1, $2];
  1172.               }
  1173.               unless (%subs) {
  1174.                 print $OUT
  1175.                   "No subroutines in $_, ignoring breakpoints.\n";
  1176.                 next;
  1177.               }
  1178.             LINES: for $line (keys %dbline) {
  1179.                 # One breakpoint per sub only:
  1180.                 my ($offset, $sub, $found);
  1181.               SUBS: for $sub (keys %subs) {
  1182.                   if ($subs{$sub}->[1] >= $line # Not after the subroutine
  1183.                   and (not defined $offset # Not caught
  1184.                        or $offset < 0 )) { # or badly caught
  1185.                 $found = $sub;
  1186.                 $offset = $line - $subs{$sub}->[0];
  1187.                 $offset = "+$offset", last SUBS if $offset >= 0;
  1188.                   }
  1189.                 }
  1190.                 if (defined $offset) {
  1191.                   $postponed{$found} =
  1192.                 "break $offset if $dbline{$line}";
  1193.                 } else {
  1194.                   print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
  1195.                 }
  1196.               }
  1197.             }
  1198.             set_list("PERLDB_POSTPONE", %postponed);
  1199.             set_list("PERLDB_PRETYPE", @$pretype);
  1200.             set_list("PERLDB_PRE", @$pre);
  1201.             set_list("PERLDB_POST", @$post);
  1202.             set_list("PERLDB_TYPEAHEAD", @typeahead);
  1203.             $ENV{PERLDB_RESTART} = 1;
  1204.             #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
  1205.             exec $^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS;
  1206.             print $OUT "exec failed: $!\n";
  1207.             last CMD; };
  1208.             $cmd =~ /^T$/ && do {
  1209.             print_trace($OUT, 1); # skip DB
  1210.             next CMD; };
  1211.             $cmd =~ /^W\s*$/ && do {
  1212.             $trace &= ~2;
  1213.             @to_watch = @old_watch = ();
  1214.             next CMD; };
  1215.             $cmd =~ /^W\b\s*(.*)/s && do {
  1216.             push @to_watch, $1;
  1217.             $evalarg = $1;
  1218.             my ($val) = &eval;
  1219.             $val = (defined $val) ? "'$val'" : 'undef' ;
  1220.             push @old_watch, $val;
  1221.             $trace |= 2;
  1222.             next CMD; };
  1223.             $cmd =~ /^\/(.*)$/ && do {
  1224.             $inpat = $1;
  1225.             $inpat =~ s:([^\\])/$:$1:;
  1226.             if ($inpat ne "") {
  1227.                 # squelch the sigmangler
  1228.                 local $SIG{__DIE__};
  1229.                 local $SIG{__WARN__};
  1230.                 eval '$inpat =~ m'."\a$inpat\a";    
  1231.                 if ($@ ne "") {
  1232.                 print $OUT "$@";
  1233.                 next CMD;
  1234.                 }
  1235.                 $pat = $inpat;
  1236.             }
  1237.             $end = $start;
  1238.             $incr = -1;
  1239.             eval '
  1240.                 for (;;) {
  1241.                 ++$start;
  1242.                 $start = 1 if ($start > $max);
  1243.                 last if ($start == $end);
  1244.                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
  1245.                     if ($slave_editor) {
  1246.                     print $OUT "\032\032$filename:$start:0\n";
  1247.                     } else {
  1248.                     print $OUT "$start:\t", $dbline[$start], "\n";
  1249.                     }
  1250.                     last;
  1251.                 }
  1252.                 } ';
  1253.             print $OUT "/$pat/: not found\n" if ($start == $end);
  1254.             next CMD; };
  1255.             $cmd =~ /^\?(.*)$/ && do {
  1256.             $inpat = $1;
  1257.             $inpat =~ s:([^\\])\?$:$1:;
  1258.             if ($inpat ne "") {
  1259.                 # squelch the sigmangler
  1260.                 local $SIG{__DIE__};
  1261.                 local $SIG{__WARN__};
  1262.                 eval '$inpat =~ m'."\a$inpat\a";    
  1263.                 if ($@ ne "") {
  1264.                 print $OUT $@;
  1265.                 next CMD;
  1266.                 }
  1267.                 $pat = $inpat;
  1268.             }
  1269.             $end = $start;
  1270.             $incr = -1;
  1271.             eval '
  1272.                 for (;;) {
  1273.                 --$start;
  1274.                 $start = $max if ($start <= 0);
  1275.                 last if ($start == $end);
  1276.                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
  1277.                     if ($slave_editor) {
  1278.                     print $OUT "\032\032$filename:$start:0\n";
  1279.                     } else {
  1280.                     print $OUT "$start:\t", $dbline[$start], "\n";
  1281.                     }
  1282.                     last;
  1283.                 }
  1284.                 } ';
  1285.             print $OUT "?$pat?: not found\n" if ($start == $end);
  1286.             next CMD; };
  1287.             $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
  1288.             pop(@hist) if length($cmd) > 1;
  1289.             $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
  1290.             $cmd = $hist[$i];
  1291.             print $OUT $cmd, "\n";
  1292.             redo CMD; };
  1293.             $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
  1294.             &system($1);
  1295.             next CMD; };
  1296.             $cmd =~ /^$rc([^$rc].*)$/ && do {
  1297.             $pat = "^$1";
  1298.             pop(@hist) if length($cmd) > 1;
  1299.             for ($i = $#hist; $i; --$i) {
  1300.                 last if $hist[$i] =~ /$pat/;
  1301.             }
  1302.             if (!$i) {
  1303.                 print $OUT "No such command!\n\n";
  1304.                 next CMD;
  1305.             }
  1306.             $cmd = $hist[$i];
  1307.             print $OUT $cmd, "\n";
  1308.             redo CMD; };
  1309.             $cmd =~ /^$sh$/ && do {
  1310.             &system($ENV{SHELL}||"/bin/sh");
  1311.             next CMD; };
  1312.             $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
  1313.             # XXX: using csh or tcsh destroys sigint retvals!
  1314.             #&system($1);  # use this instead
  1315.             &system($ENV{SHELL}||"/bin/sh","-c",$1);
  1316.             next CMD; };
  1317.             $cmd =~ /^H\b\s*(-(\d+))?/ && do {
  1318.             $end = $2 ? ($#hist-$2) : 0;
  1319.             $hist = 0 if $hist < 0;
  1320.             for ($i=$#hist; $i>$end; $i--) {
  1321.                 print $OUT "$i: ",$hist[$i],"\n"
  1322.                   unless $hist[$i] =~ /^.?$/;
  1323.             };
  1324.             next CMD; };
  1325.             $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
  1326.             runman($1);
  1327.             next CMD; };
  1328.             $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
  1329.             $cmd =~ s/^p\b/print {\$DB::OUT} /;
  1330.             $cmd =~ s/^=\s*// && do {
  1331.             my @keys;
  1332.             if (length $cmd == 0) {
  1333.                 @keys = sort keys %alias;
  1334.             } 
  1335.                         elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
  1336.                 # can't use $_ or kill //g state
  1337.                 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
  1338.                 $alias{$k} = "s\a$k\a$v\a";
  1339.                 # squelch the sigmangler
  1340.                 local $SIG{__DIE__};
  1341.                 local $SIG{__WARN__};
  1342.                 unless (eval "sub { s\a$k\a$v\a }; 1") {
  1343.                 print $OUT "Can't alias $k to $v: $@\n"; 
  1344.                 delete $alias{$k};
  1345.                 next CMD;
  1346.                 } 
  1347.                 @keys = ($k);
  1348.             } 
  1349.             else {
  1350.                 @keys = ($cmd);
  1351.             } 
  1352.             for my $k (@keys) {
  1353.                 if ((my $v = $alias{$k}) =~ ss\a$k\a(.*)\a$1) {
  1354.                 print $OUT "$k\t= $1\n";
  1355.                 } 
  1356.                 elsif (defined $alias{$k}) {
  1357.                     print $OUT "$k\t$alias{$k}\n";
  1358.                 } 
  1359.                 else {
  1360.                 print "No alias for $k\n";
  1361.                 } 
  1362.             }
  1363.             next CMD; };
  1364.             $cmd =~ /^\|\|?\s*[^|]/ && do {
  1365.             if ($pager =~ /^\|/) {
  1366.                 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
  1367.                 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
  1368.             } else {
  1369.                 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
  1370.             }
  1371.             fix_less();
  1372.             unless ($piped=open(OUT,$pager)) {
  1373.                 &warn("Can't pipe output to `$pager'");
  1374.                 if ($pager =~ /^\|/) {
  1375.                 open(OUT,">&STDOUT") # XXX: lost message
  1376.                     || &warn("Can't restore DB::OUT");
  1377.                 open(STDOUT,">&SAVEOUT")
  1378.                   || &warn("Can't restore STDOUT");
  1379.                 close(SAVEOUT);
  1380.                 } else {
  1381.                 open(OUT,">&STDOUT") # XXX: lost message
  1382.                     || &warn("Can't restore DB::OUT");
  1383.                 }
  1384.                 next CMD;
  1385.             }
  1386.             $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
  1387.                 && ("" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE});
  1388.             $selected= select(OUT);
  1389.             $|= 1;
  1390.             select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
  1391.             $cmd =~ s/^\|+\s*//;
  1392.             redo PIPE; 
  1393.             };
  1394.             # XXX Local variants do not work!
  1395.             $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
  1396.             $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
  1397.             $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
  1398.         }        # PIPE:
  1399.         $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
  1400.         if ($onetimeDump) {
  1401.         $onetimeDump = undef;
  1402.         } elsif ($term_pid == $$) {
  1403.         print $OUT "\n";
  1404.         }
  1405.     } continue {        # CMD:
  1406.         if ($piped) {
  1407.         if ($pager =~ /^\|/) {
  1408.             $? = 0;  
  1409.             # we cannot warn here: the handle is missing --tchrist
  1410.             close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
  1411.  
  1412.             # most of the $? crud was coping with broken cshisms
  1413.             if ($?) {
  1414.             print SAVEOUT "Pager `$pager' failed: ";
  1415.             if ($? == -1) {
  1416.                 print SAVEOUT "shell returned -1\n";
  1417.             } elsif ($? >> 8) {
  1418.                 print SAVEOUT 
  1419.                   ( $? & 127 ) ? " (SIG#".($?&127).")" : "", 
  1420.                   ( $? & 128 ) ? " -- core dumped" : "", "\n";
  1421.             } else {
  1422.                 print SAVEOUT "status ", ($? >> 8), "\n";
  1423.             } 
  1424.             } 
  1425.  
  1426.             open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
  1427.             open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
  1428.             $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
  1429.             # Will stop ignoring SIGPIPE if done like nohup(1)
  1430.             # does SIGINT but Perl doesn't give us a choice.
  1431.         } else {
  1432.             open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
  1433.         }
  1434.         close(SAVEOUT);
  1435.         select($selected), $selected= "" unless $selected eq "";
  1436.         $piped= "";
  1437.         }
  1438.     }            # CMD:
  1439.        $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
  1440.     foreach $evalarg (@$post) {
  1441.       &eval;
  1442.     }
  1443.     }                # if ($single || $signal)
  1444.     ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
  1445.     ();
  1446. }
  1447.  
  1448. # The following code may be executed now:
  1449. # BEGIN {warn 4}
  1450.  
  1451. sub sub {
  1452.     my ($al, $ret, @ret) = "";
  1453.     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
  1454.     $al = " for $$sub";
  1455.     }
  1456.     local $stack_depth = $stack_depth + 1; # Protect from non-local exits
  1457.     $#stack = $stack_depth;
  1458.     $stack[-1] = $single;
  1459.     $single &= 1;
  1460.     $single |= 4 if $stack_depth == $deep;
  1461.     ($frame & 4 
  1462.      ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in  "), 
  1463.      # Why -1? But it works! :-(
  1464.      print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
  1465.      : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
  1466.     if (wantarray) {
  1467.     @ret = &$sub;
  1468.     $single |= $stack[$stack_depth--];
  1469.     ($frame & 4 
  1470.      ? ( (print $LINEINFO ' ' x $stack_depth, "out "), 
  1471.          print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
  1472.      : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
  1473.     if ($doret eq $stack_depth or $frame & 16) {
  1474.             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
  1475.         print $fh ' ' x $stack_depth if $frame & 16;
  1476.         print $fh "list context return from $sub:\n"; 
  1477.         dumpit($fh, \@ret );
  1478.         $doret = -2;
  1479.     }
  1480.     @ret;
  1481.     } else {
  1482.         if (defined wantarray) {
  1483.         $ret = &$sub;
  1484.         } else {
  1485.             &$sub; undef $ret;
  1486.         };
  1487.     $single |= $stack[$stack_depth--];
  1488.     ($frame & 4 
  1489.      ? ( (print $LINEINFO ' ' x $stack_depth, "out "), 
  1490.           print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
  1491.      : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
  1492.     if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
  1493.             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
  1494.         print $fh (' ' x $stack_depth) if $frame & 16;
  1495.         print $fh (defined wantarray 
  1496.              ? "scalar context return from $sub: " 
  1497.              : "void context return from $sub\n");
  1498.         dumpit( $fh, $ret ) if defined wantarray;
  1499.         $doret = -2;
  1500.     }
  1501.     $ret;
  1502.     }
  1503. }
  1504.  
  1505. sub save {
  1506.     @saved = ($@, $!, $^E, $,, $/, $\, $^W);
  1507.     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
  1508. }
  1509.  
  1510. # The following takes its argument via $evalarg to preserve current @_
  1511.  
  1512. sub eval {
  1513.     # 'my' would make it visible from user code
  1514.     #    but so does local! --tchrist  
  1515.     local @res;            
  1516.     {
  1517.     local $otrace = $trace;
  1518.     local $osingle = $single;
  1519.     local $od = $^D;
  1520.     { ($evalarg) = $evalarg =~ /(.*)/s; }
  1521.     @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
  1522.     $trace = $otrace;
  1523.     $single = $osingle;
  1524.     $^D = $od;
  1525.     }
  1526.     my $at = $@;
  1527.     local $saved[0];        # Preserve the old value of $@
  1528.     eval { &DB::save };
  1529.     if ($at) {
  1530.     print $OUT $at;
  1531.     } elsif ($onetimeDump eq 'dump') {
  1532.     dumpit($OUT, \@res);
  1533.     } elsif ($onetimeDump eq 'methods') {
  1534.     methods($res[0]);
  1535.     }
  1536.     @res;
  1537. }
  1538.  
  1539. sub postponed_sub {
  1540.   my $subname = shift;
  1541.   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
  1542.     my $offset = $1 || 0;
  1543.     # Filename below can contain ':'
  1544.     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
  1545.     if ($i) {
  1546.       $i += $offset;
  1547.       local *dbline = $main::{'_<' . $file};
  1548.       local $^W = 0;        # != 0 is magical below
  1549.       $had_breakpoints{$file} |= 1;
  1550.       my $max = $#dbline;
  1551.       ++$i until $dbline[$i] != 0 or $i >= $max;
  1552.       $dbline{$i} = delete $postponed{$subname};
  1553.     } else {
  1554.       print $OUT "Subroutine $subname not found.\n";
  1555.     }
  1556.     return;
  1557.   }
  1558.   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
  1559.   #print $OUT "In postponed_sub for `$subname'.\n";
  1560. }
  1561.  
  1562. sub postponed {
  1563.   if ($ImmediateStop) {
  1564.     $ImmediateStop = 0;
  1565.     $signal = 1;
  1566.   }
  1567.   return &postponed_sub
  1568.     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
  1569.   # Cannot be done before the file is compiled
  1570.   local *dbline = shift;
  1571.   my $filename = $dbline;
  1572.   $filename =~ s/^_<//;
  1573.   $signal = 1, print $OUT "'$filename' loaded...\n"
  1574.     if $break_on_load{$filename};
  1575.   print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
  1576.   return unless $postponed_file{$filename};
  1577.   $had_breakpoints{$filename} |= 1;
  1578.   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
  1579.   my $key;
  1580.   for $key (keys %{$postponed_file{$filename}}) {
  1581.     $dbline{$key} = ${$postponed_file{$filename}}{$key};
  1582.   }
  1583.   delete $postponed_file{$filename};
  1584. }
  1585.  
  1586. sub dumpit {
  1587.     local ($savout) = select(shift);
  1588.     my $osingle = $single;
  1589.     my $otrace = $trace;
  1590.     $single = $trace = 0;
  1591.     local $frame = 0;
  1592.     local $doret = -2;
  1593.     unless (defined &main::dumpValue) {
  1594.     do 'dumpvar.pl';
  1595.     }
  1596.     if (defined &main::dumpValue) {
  1597.     &main::dumpValue(shift);
  1598.     } else {
  1599.     print $OUT "dumpvar.pl not available.\n";
  1600.     }
  1601.     $single = $osingle;
  1602.     $trace = $otrace;
  1603.     select ($savout);    
  1604. }
  1605.  
  1606. # Tied method do not create a context, so may get wrong message:
  1607.  
  1608. sub print_trace {
  1609.   my $fh = shift;
  1610.   my @sub = dump_trace($_[0] + 1, $_[1]);
  1611.   my $short = $_[2];        # Print short report, next one for sub name
  1612.   my $s;
  1613.   for ($i=0; $i <= $#sub; $i++) {
  1614.     last if $signal;
  1615.     local $" = ', ';
  1616.     my $args = defined $sub[$i]{args} 
  1617.     ? "(@{ $sub[$i]{args} })"
  1618.       : '' ;
  1619.     $args = (substr $args, 0, $maxtrace - 3) . '...' 
  1620.       if length $args > $maxtrace;
  1621.     my $file = $sub[$i]{file};
  1622.     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
  1623.     $s = $sub[$i]{sub};
  1624.     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;    
  1625.     if ($short) {
  1626.       my $sub = @_ >= 4 ? $_[3] : $s;
  1627.       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
  1628.     } else {
  1629.       print $fh "$sub[$i]{context} = $s$args" .
  1630.     " called from $file" . 
  1631.       " line $sub[$i]{line}\n";
  1632.     }
  1633.   }
  1634. }
  1635.  
  1636. sub dump_trace {
  1637.   my $skip = shift;
  1638.   my $count = shift || 1e9;
  1639.   $skip++;
  1640.   $count += $skip;
  1641.   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
  1642.   my $nothard = not $frame & 8;
  1643.   local $frame = 0;        # Do not want to trace this.
  1644.   my $otrace = $trace;
  1645.   $trace = 0;
  1646.   for ($i = $skip; 
  1647.        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i); 
  1648.        $i++) {
  1649.     @a = ();
  1650.     for $arg (@args) {
  1651.       my $type;
  1652.       if (not defined $arg) {
  1653.     push @a, "undef";
  1654.       } elsif ($nothard and tied $arg) {
  1655.     push @a, "tied";
  1656.       } elsif ($nothard and $type = ref $arg) {
  1657.     push @a, "ref($type)";
  1658.       } else {
  1659.     local $_ = "$arg";    # Safe to stringify now - should not call f().
  1660.     s/([\'\\])/\\$1/g;
  1661.     s/(.*)/'$1'/s
  1662.       unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
  1663.     s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  1664.     s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  1665.     push(@a, $_);
  1666.       }
  1667.     }
  1668.     $context = $context ? '@' : (defined $context ? "\$" : '.');
  1669.     $args = $h ? [@a] : undef;
  1670.     $e =~ s/\n\s*\;\s*\Z// if $e;
  1671.     $e =~ s/([\\\'])/\\$1/g if $e;
  1672.     if ($r) {
  1673.       $sub = "require '$e'";
  1674.     } elsif (defined $r) {
  1675.       $sub = "eval '$e'";
  1676.     } elsif ($sub eq '(eval)') {
  1677.       $sub = "eval {...}";
  1678.     }
  1679.     push(@sub, {context => $context, sub => $sub, args => $args,
  1680.         file => $file, line => $line});
  1681.     last if $signal;
  1682.   }
  1683.   $trace = $otrace;
  1684.   @sub;
  1685. }
  1686.  
  1687. sub action {
  1688.     my $action = shift;
  1689.     while ($action =~ s/\\$//) {
  1690.     #print $OUT "+ ";
  1691.     #$action .= "\n";
  1692.     $action .= &gets;
  1693.     }
  1694.     $action;
  1695. }
  1696.  
  1697. sub unbalanced { 
  1698.     # i hate using globals!
  1699.     $balanced_brace_re ||= qr{ 
  1700.     ^ \{
  1701.           (?:
  1702.          (?> [^{}] + )            # Non-parens without backtracking
  1703.            |
  1704.          (??{ $balanced_brace_re }) # Group with matching parens
  1705.           ) *
  1706.       \} $
  1707.    }x;
  1708.    return $_[0] !~ m/$balanced_brace_re/;
  1709. }
  1710.  
  1711. sub gets {
  1712.     &readline("cont: ");
  1713. }
  1714.  
  1715. sub system {
  1716.     # We save, change, then restore STDIN and STDOUT to avoid fork() since
  1717.     # some non-Unix systems can do system() but have problems with fork().
  1718.     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
  1719.     open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
  1720.     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
  1721.     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
  1722.  
  1723.     # XXX: using csh or tcsh destroys sigint retvals!
  1724.     system(@_);
  1725.     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
  1726.     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
  1727.     close(SAVEIN); 
  1728.     close(SAVEOUT);
  1729.  
  1730.  
  1731.     # most of the $? crud was coping with broken cshisms
  1732.     if ($? >> 8) {
  1733.     &warn("(Command exited ", ($? >> 8), ")\n");
  1734.     } elsif ($?) { 
  1735.     &warn( "(Command died of SIG#",  ($? & 127),
  1736.         (($? & 128) ? " -- core dumped" : "") , ")", "\n");
  1737.     } 
  1738.  
  1739.     return $?;
  1740.  
  1741. }
  1742.  
  1743. sub setterm {
  1744.     local $frame = 0;
  1745.     local $doret = -2;
  1746.     eval { require Term::ReadLine } or die $@;
  1747.     if ($notty) {
  1748.     if ($tty) {
  1749.         open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
  1750.         open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
  1751.         $IN = \*IN;
  1752.         $OUT = \*OUT;
  1753.         my $sel = select($OUT);
  1754.         $| = 1;
  1755.         select($sel);
  1756.     } else {
  1757.         eval "require Term::Rendezvous;" or die;
  1758.         my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
  1759.         my $term_rv = new Term::Rendezvous $rv;
  1760.         $IN = $term_rv->IN;
  1761.         $OUT = $term_rv->OUT;
  1762.     }
  1763.     }
  1764.     if (!$rl) {
  1765.     $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
  1766.     } else {
  1767.     $term = new Term::ReadLine 'perldb', $IN, $OUT;
  1768.  
  1769.     $rl_attribs = $term->Attribs;
  1770.     $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' 
  1771.       if defined $rl_attribs->{basic_word_break_characters} 
  1772.         and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
  1773.     $rl_attribs->{special_prefixes} = '$@&%';
  1774.     $rl_attribs->{completer_word_break_characters} .= '$@&%';
  1775.     $rl_attribs->{completion_function} = \&db_complete; 
  1776.     }
  1777.     $LINEINFO = $OUT unless defined $LINEINFO;
  1778.     $lineinfo = $console unless defined $lineinfo;
  1779.     $term->MinLine(2);
  1780.     if ($term->Features->{setHistory} and "@hist" ne "?") {
  1781.       $term->SetHistory(@hist);
  1782.     }
  1783.     ornaments($ornaments) if defined $ornaments;
  1784.     $term_pid = $$;
  1785. }
  1786.  
  1787. sub resetterm {            # We forked, so we need a different TTY
  1788.     $term_pid = $$;
  1789.     if (defined &get_fork_TTY) {
  1790.       &get_fork_TTY;
  1791.     } elsif (not defined $fork_TTY 
  1792.          and defined $ENV{TERM} and $ENV{TERM} eq 'xterm' 
  1793.          and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) { 
  1794.         # Possibly _inside_ XTERM
  1795.         open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
  1796.  sleep 10000000' |];
  1797.         $fork_TTY = <XT>;
  1798.         chomp $fork_TTY;
  1799.     }
  1800.     if (defined $fork_TTY) {
  1801.       TTY($fork_TTY);
  1802.       undef $fork_TTY;
  1803.     } else {
  1804.       print_help(<<EOP);
  1805. I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
  1806.   Define B<\$DB::fork_TTY> 
  1807.        - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
  1808.   The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
  1809.   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
  1810.   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
  1811. EOP
  1812.     }
  1813. }
  1814.  
  1815. sub readline {
  1816.   local $.;
  1817.   if (@typeahead) {
  1818.     my $left = @typeahead;
  1819.     my $got = shift @typeahead;
  1820.     print $OUT "auto(-$left)", shift, $got, "\n";
  1821.     $term->AddHistory($got) 
  1822.       if length($got) > 1 and defined $term->Features->{addHistory};
  1823.     return $got;
  1824.   }
  1825.   local $frame = 0;
  1826.   local $doret = -2;
  1827.   if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
  1828.     $OUT->write(join('', @_));
  1829.     my $stuff;
  1830.     $IN->recv( $stuff, 2048 );  # XXX: what's wrong with sysread?
  1831.     $stuff;
  1832.   }
  1833.   else {
  1834.     $term->readline(@_);
  1835.   }
  1836. }
  1837.  
  1838. sub dump_option {
  1839.     my ($opt, $val)= @_;
  1840.     $val = option_val($opt,'N/A');
  1841.     $val =~ s/([\\\'])/\\$1/g;
  1842.     printf $OUT "%20s = '%s'\n", $opt, $val;
  1843. }
  1844.  
  1845. sub option_val {
  1846.     my ($opt, $default)= @_;
  1847.     my $val;
  1848.     if (defined $optionVars{$opt}
  1849.     and defined ${$optionVars{$opt}}) {
  1850.     $val = ${$optionVars{$opt}};
  1851.     } elsif (defined $optionAction{$opt}
  1852.     and defined &{$optionAction{$opt}}) {
  1853.     $val = &{$optionAction{$opt}}();
  1854.     } elsif (defined $optionAction{$opt}
  1855.          and not defined $option{$opt}
  1856.          or defined $optionVars{$opt}
  1857.          and not defined ${$optionVars{$opt}}) {
  1858.     $val = $default;
  1859.     } else {
  1860.     $val = $option{$opt};
  1861.     }
  1862.     $val
  1863. }
  1864.  
  1865. sub parse_options {
  1866.     local($_)= @_;
  1867.     # too dangerous to let intuitive usage overwrite important things
  1868.     # defaultion should never be the default
  1869.     my %opt_needs_val = map { ( $_ => 1 ) } qw{
  1870.         arrayDepth hashDepth LineInfo maxTraceLen ornaments
  1871.         pager quote ReadLine recallCommand RemotePort ShellBang TTY
  1872.     };
  1873.     while (length) {
  1874.     my $val_defaulted;
  1875.     s/^\s+// && next;
  1876.     s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
  1877.     my ($opt,$sep) = ($1,$2);
  1878.     my $val;
  1879.     if ("?" eq $sep) {
  1880.         print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
  1881.           if /^\S/;
  1882.         #&dump_option($opt);
  1883.     } elsif ($sep !~ /\S/) {
  1884.         $val_defaulted = 1;
  1885.         $val = "1";  #  this is an evil default; make 'em set it!
  1886.     } elsif ($sep eq "=") {
  1887.  
  1888.             if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) { 
  1889.                 my $quote = $1;
  1890.                 ($val = $2) =~ s/\\([$quote\\])/$1/g;
  1891.         } else { 
  1892.         s/^(\S*)//;
  1893.         $val = $1;
  1894.         print OUT qq(Option better cleared using $opt=""\n)
  1895.             unless length $val;
  1896.         }
  1897.  
  1898.     } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
  1899.         my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
  1900.         s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
  1901.           print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
  1902.         ($val = $1) =~ s/\\([\\$end])/$1/g;
  1903.     }
  1904.  
  1905.     my $option;
  1906.     my $matches = grep( /^\Q$opt/  && ($option = $_),  @options  )
  1907.            || grep( /^\Q$opt/i && ($option = $_),  @options  );
  1908.  
  1909.     print($OUT "Unknown option `$opt'\n"), next     unless $matches;
  1910.     print($OUT "Ambiguous option `$opt'\n"), next     if $matches > 1;
  1911.  
  1912.        if ($opt_needs_val{$option} && $val_defaulted) {
  1913.         print $OUT "Option `$opt' is non-boolean.  Use `O $option=VAL' to set, `O $option?' to query\n";
  1914.         next;
  1915.     } 
  1916.  
  1917.     $option{$option} = $val if defined $val;
  1918.  
  1919.     eval qq{
  1920.         local \$frame = 0; 
  1921.         local \$doret = -2; 
  1922.             require '$optionRequire{$option}';
  1923.         1;
  1924.      } || die  # XXX: shouldn't happen
  1925.         if  defined $optionRequire{$option}        &&
  1926.             defined $val;
  1927.  
  1928.     ${$optionVars{$option}} = $val         
  1929.         if  defined $optionVars{$option}        &&
  1930.         defined $val;
  1931.  
  1932.     &{$optionAction{$option}} ($val)    
  1933.         if defined $optionAction{$option}        &&
  1934.                defined &{$optionAction{$option}}    &&
  1935.                defined $val;
  1936.  
  1937.     # Not $rcfile
  1938.     dump_option($option)     unless $OUT eq \*STDERR; 
  1939.     }
  1940. }
  1941.  
  1942. sub set_list {
  1943.   my ($stem,@list) = @_;
  1944.   my $val;
  1945.   $ENV{"${stem}_n"} = @list;
  1946.   for $i (0 .. $#list) {
  1947.     $val = $list[$i];
  1948.     $val =~ s/\\/\\\\/g;
  1949.     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
  1950.     $ENV{"${stem}_$i"} = $val;
  1951.   }
  1952. }
  1953.  
  1954. sub get_list {
  1955.   my $stem = shift;
  1956.   my @list;
  1957.   my $n = delete $ENV{"${stem}_n"};
  1958.   my $val;
  1959.   for $i (0 .. $n - 1) {
  1960.     $val = delete $ENV{"${stem}_$i"};
  1961.     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
  1962.     push @list, $val;
  1963.   }
  1964.   @list;
  1965. }
  1966.  
  1967. sub catch {
  1968.     $signal = 1;
  1969.     return;            # Put nothing on the stack - malloc/free land!
  1970. }
  1971.  
  1972. sub warn {
  1973.     my($msg)= join("",@_);
  1974.     $msg .= ": $!\n" unless $msg =~ /\n$/;
  1975.     print $OUT $msg;
  1976. }
  1977.  
  1978. sub TTY {
  1979.     if (@_ and $term and $term->Features->{newTTY}) {
  1980.       my ($in, $out) = shift;
  1981.       if ($in =~ /,/) {
  1982.     ($in, $out) = split /,/, $in, 2;
  1983.       } else {
  1984.     $out = $in;
  1985.       }
  1986.       open IN, $in or die "cannot open `$in' for read: $!";
  1987.       open OUT, ">$out" or die "cannot open `$out' for write: $!";
  1988.       $term->newTTY(\*IN, \*OUT);
  1989.       $IN    = \*IN;
  1990.       $OUT    = \*OUT;
  1991.       return $tty = $in;
  1992.     } elsif ($term and @_) {
  1993.     &warn("Too late to set TTY, enabled on next `R'!\n");
  1994.     } 
  1995.     $tty = shift if @_;
  1996.     $tty or $console;
  1997. }
  1998.  
  1999. sub noTTY {
  2000.     if ($term) {
  2001.     &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
  2002.     }
  2003.     $notty = shift if @_;
  2004.     $notty;
  2005. }
  2006.  
  2007. sub ReadLine {
  2008.     if ($term) {
  2009.     &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
  2010.     }
  2011.     $rl = shift if @_;
  2012.     $rl;
  2013. }
  2014.  
  2015. sub RemotePort {
  2016.     if ($term) {
  2017.         &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
  2018.     }
  2019.     $remoteport = shift if @_;
  2020.     $remoteport;
  2021. }
  2022.  
  2023. sub tkRunning {
  2024.     if (${$term->Features}{tkRunning}) {
  2025.         return $term->tkRunning(@_);
  2026.     } else {
  2027.     print $OUT "tkRunning not supported by current ReadLine package.\n";
  2028.     0;
  2029.     }
  2030. }
  2031.  
  2032. sub NonStop {
  2033.     if ($term) {
  2034.     &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
  2035.     }
  2036.     $runnonstop = shift if @_;
  2037.     $runnonstop;
  2038. }
  2039.  
  2040. sub pager {
  2041.     if (@_) {
  2042.     $pager = shift;
  2043.     $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
  2044.     }
  2045.     $pager;
  2046. }
  2047.  
  2048. sub shellBang {
  2049.     if (@_) {
  2050.     $sh = quotemeta shift;
  2051.     $sh .= "\\b" if $sh =~ /\w$/;
  2052.     }
  2053.     $psh = $sh;
  2054.     $psh =~ s/\\b$//;
  2055.     $psh =~ s/\\(.)/$1/g;
  2056.     &sethelp;
  2057.     $psh;
  2058. }
  2059.  
  2060. sub ornaments {
  2061.   if (defined $term) {
  2062.     local ($warnLevel,$dieLevel) = (0, 1);
  2063.     return '' unless $term->Features->{ornaments};
  2064.     eval { $term->ornaments(@_) } || '';
  2065.   } else {
  2066.     $ornaments = shift;
  2067.   }
  2068. }
  2069.  
  2070. sub recallCommand {
  2071.     if (@_) {
  2072.     $rc = quotemeta shift;
  2073.     $rc .= "\\b" if $rc =~ /\w$/;
  2074.     }
  2075.     $prc = $rc;
  2076.     $prc =~ s/\\b$//;
  2077.     $prc =~ s/\\(.)/$1/g;
  2078.     &sethelp;
  2079.     $prc;
  2080. }
  2081.  
  2082. sub LineInfo {
  2083.     return $lineinfo unless @_;
  2084.     $lineinfo = shift;
  2085.     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
  2086.     $slave_editor = ($stream =~ /^\|/);
  2087.     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
  2088.     $LINEINFO = \*LINEINFO;
  2089.     my $save = select($LINEINFO);
  2090.     $| = 1;
  2091.     select($save);
  2092.     $lineinfo;
  2093. }
  2094.  
  2095. sub list_versions {
  2096.   my %version;
  2097.   my $file;
  2098.   for (keys %INC) {
  2099.     $file = $_;
  2100.     s,\.p[lm]$,,i ;
  2101.     s,/,::,g ;
  2102.     s/^perl5db$/DB/;
  2103.     s/^Term::ReadLine::readline$/readline/;
  2104.     if (defined ${ $_ . '::VERSION' }) {
  2105.       $version{$file} = "${ $_ . '::VERSION' } from ";
  2106.     } 
  2107.     $version{$file} .= $INC{$file};
  2108.   }
  2109.   dumpit($OUT,\%version);
  2110. }
  2111.  
  2112. sub sethelp {
  2113.     # XXX: make sure these are tabs between the command and explantion,
  2114.     #      or print_help will screw up your formatting if you have
  2115.     #      eeevil ornaments enabled.  This is an insane mess.
  2116.  
  2117.     $help = "
  2118. B<T>        Stack trace.
  2119. B<s> [I<expr>]    Single step [in I<expr>].
  2120. B<n> [I<expr>]    Next, steps over subroutine calls [in I<expr>].
  2121. <B<CR>>        Repeat last B<n> or B<s> command.
  2122. B<r>        Return from current subroutine.
  2123. B<c> [I<line>|I<sub>]    Continue; optionally inserts a one-time-only breakpoint
  2124.         at the specified position.
  2125. B<l> I<min>B<+>I<incr>    List I<incr>+1 lines starting at I<min>.
  2126. B<l> I<min>B<->I<max>    List lines I<min> through I<max>.
  2127. B<l> I<line>        List single I<line>.
  2128. B<l> I<subname>    List first window of lines from subroutine.
  2129. B<l> I<\$var>        List first window of lines from subroutine referenced by I<\$var>.
  2130. B<l>        List next window of lines.
  2131. B<->        List previous window of lines.
  2132. B<w> [I<line>]    List window around I<line>.
  2133. B<.>        Return to the executed line.
  2134. B<f> I<filename>    Switch to viewing I<filename>. File must be already loaded.
  2135.         I<filename> may be either the full name of the file, or a regular
  2136.         expression matching the full file name:
  2137.         B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
  2138.         Evals (with saved bodies) are considered to be filenames:
  2139.         B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
  2140.         (in the order of execution).
  2141. B</>I<pattern>B</>    Search forwards for I<pattern>; final B</> is optional.
  2142. B<?>I<pattern>B<?>    Search backwards for I<pattern>; final B<?> is optional.
  2143. B<L>        List all breakpoints and actions.
  2144. B<S> [[B<!>]I<pattern>]    List subroutine names [not] matching I<pattern>.
  2145. B<t>        Toggle trace mode.
  2146. B<t> I<expr>        Trace through execution of I<expr>.
  2147. B<b> [I<line>] [I<condition>]
  2148.         Set breakpoint; I<line> defaults to the current execution line;
  2149.         I<condition> breaks if it evaluates to true, defaults to '1'.
  2150. B<b> I<subname> [I<condition>]
  2151.         Set breakpoint at first line of subroutine.
  2152. B<b> I<\$var>        Set breakpoint at first line of subroutine referenced by I<\$var>.
  2153. B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
  2154. B<b> B<postpone> I<subname> [I<condition>]
  2155.         Set breakpoint at first line of subroutine after 
  2156.         it is compiled.
  2157. B<b> B<compile> I<subname>
  2158.         Stop after the subroutine is compiled.
  2159. B<d> [I<line>]    Delete the breakpoint for I<line>.
  2160. B<D>        Delete all breakpoints.
  2161. B<a> [I<line>] I<command>
  2162.         Set an action to be done before the I<line> is executed;
  2163.         I<line> defaults to the current execution line.
  2164.         Sequence is: check for breakpoint/watchpoint, print line
  2165.         if necessary, do action, prompt user if necessary,
  2166.         execute line.
  2167. B<a> [I<line>]    Delete the action for I<line>.
  2168. B<A>        Delete all actions.
  2169. B<W> I<expr>        Add a global watch-expression.
  2170. B<W>        Delete all watch-expressions.
  2171. B<V> [I<pkg> [I<vars>]]    List some (default all) variables in package (default current).
  2172.         Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
  2173. B<X> [I<vars>]    Same as \"B<V> I<currentpackage> [I<vars>]\".
  2174. B<x> I<expr>        Evals expression in list context, dumps the result.
  2175. B<m> I<expr>        Evals expression in list context, prints methods callable
  2176.         on the first element of the result.
  2177. B<m> I<class>        Prints methods callable via the given class.
  2178.  
  2179. B<<> ?            List Perl commands to run before each prompt.
  2180. B<<> I<expr>        Define Perl command to run before each prompt.
  2181. B<<<> I<expr>        Add to the list of Perl commands to run before each prompt.
  2182. B<>> ?            List Perl commands to run after each prompt.
  2183. B<>> I<expr>        Define Perl command to run after each prompt.
  2184. B<>>B<>> I<expr>        Add to the list of Perl commands to run after each prompt.
  2185. B<{> I<db_command>    Define debugger command to run before each prompt.
  2186. B<{> ?            List debugger commands to run before each prompt.
  2187. B<<> I<expr>        Define Perl command to run before each prompt.
  2188. B<{{> I<db_command>    Add to the list of debugger commands to run before each prompt.
  2189. B<$prc> I<number>    Redo a previous command (default previous command).
  2190. B<$prc> I<-number>    Redo number'th-to-last command.
  2191. B<$prc> I<pattern>    Redo last command that started with I<pattern>.
  2192.         See 'B<O> I<recallCommand>' too.
  2193. B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
  2194.   . ( $rc eq $sh ? "" : "
  2195. B<$psh> [I<cmd>]     Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
  2196.         See 'B<O> I<shellBang>' too.
  2197. B<H> I<-number>    Display last number commands (default all).
  2198. B<p> I<expr>        Same as \"I<print {DB::OUT} expr>\" in current package.
  2199. B<|>I<dbcmd>        Run debugger command, piping DB::OUT to current pager.
  2200. B<||>I<dbcmd>        Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
  2201. B<\=> [I<alias> I<value>]    Define a command alias, or list current aliases.
  2202. I<command>        Execute as a perl statement in current package.
  2203. B<v>        Show versions of loaded modules.
  2204. B<R>        Pure-man-restart of debugger, some of debugger state
  2205.         and command-line options may be lost.
  2206.         Currently the following setting are preserved: 
  2207.         history, breakpoints and actions, debugger B<O>ptions 
  2208.         and the following command-line options: I<-w>, I<-I>, I<-e>.
  2209.  
  2210. B<O> [I<opt>] ...    Set boolean option to true
  2211. B<O> [I<opt>B<?>]    Query options
  2212. B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ... 
  2213.         Set options.  Use quotes in spaces in value.
  2214.     I<recallCommand>, I<ShellBang>    chars used to recall command or spawn shell;
  2215.     I<pager>            program for output of \"|cmd\";
  2216.     I<tkRunning>            run Tk while prompting (with ReadLine);
  2217.     I<signalLevel> I<warnLevel> I<dieLevel>    level of verbosity;
  2218.     I<inhibit_exit>        Allows stepping off the end of the script.
  2219.     I<ImmediateStop>        Debugger should stop as early as possible.
  2220.     I<RemotePort>            Remote hostname:port for remote debugging
  2221.   The following options affect what happens with B<V>, B<X>, and B<x> commands:
  2222.     I<arrayDepth>, I<hashDepth>     print only first N elements ('' for all);
  2223.     I<compactDump>, I<veryCompact>     change style of array and hash dump;
  2224.     I<globPrint>             whether to print contents of globs;
  2225.     I<DumpDBFiles>         dump arrays holding debugged files;
  2226.     I<DumpPackages>         dump symbol tables of packages;
  2227.     I<DumpReused>             dump contents of \"reused\" addresses;
  2228.     I<quote>, I<HighBit>, I<undefPrint>     change style of string dump;
  2229.     I<bareStringify>         Do not print the overload-stringified value;
  2230.   Other options include:
  2231.     I<PrintRet>        affects printing of return value after B<r> command,
  2232.     I<frame>        affects printing messages on entry and exit from subroutines.
  2233.     I<AutoTrace>    affects printing messages on every possible breaking point.
  2234.     I<maxTraceLen>    gives maximal length of evals/args listed in stack trace.
  2235.     I<ornaments>     affects screen appearance of the command line.
  2236.     During startup options are initialized from \$ENV{PERLDB_OPTS}.
  2237.     You can put additional initialization options I<TTY>, I<noTTY>,
  2238.     I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
  2239.     `B<R>' after you set them).
  2240.  
  2241. B<q> or B<^D>        Quit. Set B<\$DB::finished = 0> to debug global destruction.
  2242. B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
  2243. B<h h>        Summary of debugger commands.
  2244. B<$doccmd> I<manpage>    Runs the external doc viewer B<$doccmd> command on the 
  2245.         named Perl I<manpage>, or on B<$doccmd> itself if omitted.
  2246.         Set B<\$DB::doccmd> to change viewer.
  2247.  
  2248. Type `|h' for a paged display if this was too hard to read.
  2249.  
  2250. "; # Fix balance of vi % matching: } }}
  2251.  
  2252.     $summary = <<"END_SUM";
  2253. I<List/search source lines:>               I<Control script execution:>
  2254.   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
  2255.   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
  2256.   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
  2257.   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
  2258.   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
  2259.   B<v>          Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
  2260. I<Debugger controls:>                        B<L>           List break/watch/actions
  2261.   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
  2262.   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
  2263.   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
  2264.   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
  2265.   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
  2266.   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
  2267.   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
  2268.   B<q> or B<^D>     Quit              B<R>          Attempt a restart
  2269. I<Data Examination:>          B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
  2270.   B<x>|B<m> I<expr>    Evals expr in list context, dumps the result or lists methods.
  2271.   B<p> I<expr>    Print expression (uses script's current package).
  2272.   B<S> [[B<!>]I<pat>]    List subroutine names [not] matching pattern
  2273.   B<V> [I<Pk> [I<Vars>]]    List Variables in Package.  Vars can be ~pattern or !pattern.
  2274.   B<X> [I<Vars>]    Same as \"B<V> I<current_package> [I<Vars>]\".
  2275. For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
  2276. END_SUM
  2277.                 # ')}}; # Fix balance of vi % matching
  2278. }
  2279.  
  2280. sub print_help {
  2281.     local $_ = shift;
  2282.  
  2283.     # Restore proper alignment destroyed by eeevil I<> and B<>
  2284.     # ornaments: A pox on both their houses!
  2285.     #
  2286.     # A help command will have everything up to and including
  2287.     # the first tab sequence paddeed into a field 16 (or if indented 20)
  2288.     # wide.  If it's wide than that, an extra space will be added.
  2289.     s{
  2290.     ^                 # only matters at start of line
  2291.       ( \040{4} | \t )*    # some subcommands are indented
  2292.       ( < ?         # so <CR> works
  2293.         [BI] < [^\t\n] + )  # find an eeevil ornament
  2294.       ( \t+ )        # original separation, discarded
  2295.       ( .* )        # this will now start (no earlier) than 
  2296.                 # column 16
  2297.     } {
  2298.     my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
  2299.     my $clean = $command;
  2300.     $clean =~ s/[BI]<([^>]*)>/$1/g;  
  2301.     # replace with this whole string:
  2302.     (length($leadwhite) ? " " x 4 : "")
  2303.       . $command
  2304.       . ((" " x (16 + (length($leadwhite) ? 4 : 0) - length($clean))) || " ")
  2305.       . $text;
  2306.  
  2307.     }mgex;
  2308.  
  2309.     s{                # handle bold ornaments
  2310.     B < ( [^>] + | > ) >
  2311.     } {
  2312.       $Term::ReadLine::TermCap::rl_term_set[2] 
  2313.     . $1
  2314.     . $Term::ReadLine::TermCap::rl_term_set[3]
  2315.     }gex;
  2316.  
  2317.     s{                # handle italic ornaments
  2318.     I < ( [^>] + | > ) >
  2319.     } {
  2320.       $Term::ReadLine::TermCap::rl_term_set[0] 
  2321.     . $1
  2322.     . $Term::ReadLine::TermCap::rl_term_set[1]
  2323.     }gex;
  2324.  
  2325.     print $OUT $_;
  2326. }
  2327.  
  2328. sub fix_less {
  2329.     return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
  2330.     my $is_less = $pager =~ /\bless\b/;
  2331.     if ($pager =~ /\bmore\b/) { 
  2332.     my @st_more = stat('/usr/bin/more');
  2333.     my @st_less = stat('/usr/bin/less');
  2334.     $is_less = @st_more    && @st_less 
  2335.         && $st_more[0] == $st_less[0] 
  2336.         && $st_more[1] == $st_less[1];
  2337.     }
  2338.     # changes environment!
  2339.     $ENV{LESS} .= 'r'     if $is_less;
  2340. }
  2341.  
  2342. sub diesignal {
  2343.     local $frame = 0;
  2344.     local $doret = -2;
  2345.     $SIG{'ABRT'} = 'DEFAULT';
  2346.     kill 'ABRT', $$ if $panic++;
  2347.     if (defined &Carp::longmess) {
  2348.     local $SIG{__WARN__} = '';
  2349.     local $Carp::CarpLevel = 2;        # mydie + confess
  2350.     &warn(Carp::longmess("Signal @_"));
  2351.     }
  2352.     else {
  2353.     print $DB::OUT "Got signal @_\n";
  2354.     }
  2355.     kill 'ABRT', $$;
  2356. }
  2357.  
  2358. sub dbwarn { 
  2359.   local $frame = 0;
  2360.   local $doret = -2;
  2361.   local $SIG{__WARN__} = '';
  2362.   local $SIG{__DIE__} = '';
  2363.   eval { require Carp } if defined $^S;    # If error/warning during compilation,
  2364.                                         # require may be broken.
  2365.   warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
  2366.     return unless defined &Carp::longmess;
  2367.   my ($mysingle,$mytrace) = ($single,$trace);
  2368.   $single = 0; $trace = 0;
  2369.   my $mess = Carp::longmess(@_);
  2370.   ($single,$trace) = ($mysingle,$mytrace);
  2371.   &warn($mess); 
  2372. }
  2373.  
  2374. sub dbdie {
  2375.   local $frame = 0;
  2376.   local $doret = -2;
  2377.   local $SIG{__DIE__} = '';
  2378.   local $SIG{__WARN__} = '';
  2379.   my $i = 0; my $ineval = 0; my $sub;
  2380.   if ($dieLevel > 2) {
  2381.       local $SIG{__WARN__} = \&dbwarn;
  2382.       &warn(@_);        # Yell no matter what
  2383.       return;
  2384.   }
  2385.   if ($dieLevel < 2) {
  2386.     die @_ if $^S;        # in eval propagate
  2387.   }
  2388.   eval { require Carp } if defined $^S;    # If error/warning during compilation,
  2389.                                     # require may be broken.
  2390.  
  2391.   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
  2392.     unless defined &Carp::longmess;
  2393.  
  2394.   # We do not want to debug this chunk (automatic disabling works
  2395.   # inside DB::DB, but not in Carp).
  2396.   my ($mysingle,$mytrace) = ($single,$trace);
  2397.   $single = 0; $trace = 0;
  2398.   my $mess = Carp::longmess(@_);
  2399.   ($single,$trace) = ($mysingle,$mytrace);
  2400.   die $mess;
  2401. }
  2402.  
  2403. sub warnLevel {
  2404.   if (@_) {
  2405.     $prevwarn = $SIG{__WARN__} unless $warnLevel;
  2406.     $warnLevel = shift;
  2407.     if ($warnLevel) {
  2408.       $SIG{__WARN__} = \&DB::dbwarn;
  2409.     } else {
  2410.       $SIG{__WARN__} = $prevwarn;
  2411.     }
  2412.   }
  2413.   $warnLevel;
  2414. }
  2415.  
  2416. sub dieLevel {
  2417.   if (@_) {
  2418.     $prevdie = $SIG{__DIE__} unless $dieLevel;
  2419.     $dieLevel = shift;
  2420.     if ($dieLevel) {
  2421.       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
  2422.       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
  2423.       print $OUT "Stack dump during die enabled", 
  2424.         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
  2425.       if $I_m_init;
  2426.       print $OUT "Dump printed too.\n" if $dieLevel > 2;
  2427.     } else {
  2428.       $SIG{__DIE__} = $prevdie;
  2429.       print $OUT "Default die handler restored.\n";
  2430.     }
  2431.   }
  2432.   $dieLevel;
  2433. }
  2434.  
  2435. sub signalLevel {
  2436.   if (@_) {
  2437.     $prevsegv = $SIG{SEGV} unless $signalLevel;
  2438.     $prevbus = $SIG{BUS} unless $signalLevel;
  2439.     $signalLevel = shift;
  2440.     if ($signalLevel) {
  2441.       $SIG{SEGV} = \&DB::diesignal;
  2442.       $SIG{BUS} = \&DB::diesignal;
  2443.     } else {
  2444.       $SIG{SEGV} = $prevsegv;
  2445.       $SIG{BUS} = $prevbus;
  2446.     }
  2447.   }
  2448.   $signalLevel;
  2449. }
  2450.  
  2451. sub CvGV_name {
  2452.   my $in = shift;
  2453.   my $name = CvGV_name_or_bust($in);
  2454.   defined $name ? $name : $in;
  2455. }
  2456.  
  2457. sub CvGV_name_or_bust {
  2458.   my $in = shift;
  2459.   return if $skipCvGV;        # Backdoor to avoid problems if XS broken...
  2460.   $in = \&$in;            # Hard reference...
  2461.   eval {require Devel::Peek; 1} or return;
  2462.   my $gv = Devel::Peek::CvGV($in) or return;
  2463.   *$gv{PACKAGE} . '::' . *$gv{NAME};
  2464. }
  2465.  
  2466. sub find_sub {
  2467.   my $subr = shift;
  2468.   $sub{$subr} or do {
  2469.     return unless defined &$subr;
  2470.     my $name = CvGV_name_or_bust($subr);
  2471.     my $data;
  2472.     $data = $sub{$name} if defined $name;
  2473.     return $data if defined $data;
  2474.  
  2475.     # Old stupid way...
  2476.     $subr = \&$subr;        # Hard reference
  2477.     my $s;
  2478.     for (keys %sub) {
  2479.       $s = $_, last if $subr eq \&$_;
  2480.     }
  2481.     $sub{$s} if $s;
  2482.   }
  2483. }
  2484.  
  2485. sub methods {
  2486.   my $class = shift;
  2487.   $class = ref $class if ref $class;
  2488.   local %seen;
  2489.   local %packs;
  2490.   methods_via($class, '', 1);
  2491.   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
  2492. }
  2493.  
  2494. sub methods_via {
  2495.   my $class = shift;
  2496.   return if $packs{$class}++;
  2497.   my $prefix = shift;
  2498.   my $prepend = $prefix ? "via $prefix: " : '';
  2499.   my $name;
  2500.   for $name (grep {defined &{${"${class}::"}{$_}}} 
  2501.          sort keys %{"${class}::"}) {
  2502.     next if $seen{ $name }++;
  2503.     print $DB::OUT "$prepend$name\n";
  2504.   }
  2505.   return unless shift;        # Recurse?
  2506.   for $name (@{"${class}::ISA"}) {
  2507.     $prepend = $prefix ? $prefix . " -> $name" : $name;
  2508.     methods_via($name, $prepend, 1);
  2509.   }
  2510. }
  2511.  
  2512. sub setman { 
  2513.     $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s
  2514.         ? "man"             # O Happy Day!
  2515.         : "perldoc";        # Alas, poor unfortunates
  2516. }
  2517.  
  2518. sub runman {
  2519.     my $page = shift;
  2520.     unless ($page) {
  2521.     &system("$doccmd $doccmd");
  2522.     return;
  2523.     } 
  2524.     # this way user can override, like with $doccmd="man -Mwhatever"
  2525.     # or even just "man " to disable the path check.
  2526.     unless ($doccmd eq 'man') {
  2527.     &system("$doccmd $page");
  2528.     return;
  2529.     } 
  2530.  
  2531.     $page = 'perl' if lc($page) eq 'help';
  2532.  
  2533.     require Config;
  2534.     my $man1dir = $Config::Config{'man1dir'};
  2535.     my $man3dir = $Config::Config{'man3dir'};
  2536.     for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ } 
  2537.     my $manpath = '';
  2538.     $manpath .= "$man1dir:" if $man1dir =~ /\S/;
  2539.     $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
  2540.     chop $manpath if $manpath;
  2541.     # harmless if missing, I figure
  2542.     my $oldpath = $ENV{MANPATH};
  2543.     $ENV{MANPATH} = $manpath if $manpath;
  2544.     my $nopathopt = $^O =~ /dunno what goes here/;
  2545.     if (system($doccmd, 
  2546.         # I just *know* there are men without -M
  2547.         (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),  
  2548.         split ' ', $page) )
  2549.     {
  2550.     unless ($page =~ /^perl\w/) {
  2551.         if (grep { $page eq $_ } qw{ 
  2552.         5004delta 5005delta amiga api apio book boot bot call compile
  2553.         cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
  2554.         faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
  2555.         form func guts hack hist hpux intern ipc lexwarn locale lol mod
  2556.         modinstall modlib number obj op opentut os2 os390 pod port 
  2557.         ref reftut run sec style sub syn thrtut tie toc todo toot tootc
  2558.         trap unicode var vms win32 xs xstut
  2559.           }) 
  2560.         {
  2561.         $page =~ s/^/perl/;
  2562.         system($doccmd, 
  2563.             (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),  
  2564.             $page);
  2565.         }
  2566.     }
  2567.     } 
  2568.     if (defined $oldpath) {
  2569.     $ENV{MANPATH} = $manpath;
  2570.     } else {
  2571.     delete $ENV{MANPATH};
  2572.     } 
  2573. } 
  2574.  
  2575. # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
  2576.  
  2577. BEGIN {            # This does not compile, alas.
  2578.   $IN = \*STDIN;        # For bugs before DB::OUT has been opened
  2579.   $OUT = \*STDERR;        # For errors before DB::OUT has been opened
  2580.   $sh = '!';
  2581.   $rc = ',';
  2582.   @hist = ('?');
  2583.   $deep = 100;            # warning if stack gets this deep
  2584.   $window = 10;
  2585.   $preview = 3;
  2586.   $sub = '';
  2587.   $SIG{INT} = \&DB::catch;
  2588.   # This may be enabled to debug debugger:
  2589.   #$warnLevel = 1 unless defined $warnLevel;
  2590.   #$dieLevel = 1 unless defined $dieLevel;
  2591.   #$signalLevel = 1 unless defined $signalLevel;
  2592.  
  2593.   $db_stop = 0;            # Compiler warning
  2594.   $db_stop = 1 << 30;
  2595.   $level = 0;            # Level of recursive debugging
  2596.   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
  2597.   # Triggers bug (?) in perl is we postpone this until runtime:
  2598.   @postponed = @stack = (0);
  2599.   $stack_depth = 0;        # Localized $#stack
  2600.   $doret = -2;
  2601.   $frame = 0;
  2602. }
  2603.  
  2604. BEGIN {$^W = $ini_warn;}    # Switch warnings back
  2605.  
  2606. #use Carp;            # This did break, left for debuggin
  2607.  
  2608. sub db_complete {
  2609.   # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
  2610.   my($text, $line, $start) = @_;
  2611.   my ($itext, $search, $prefix, $pack) =
  2612.     ($text, "^\Q${'package'}::\E([^:]+)\$");
  2613.   
  2614.   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
  2615.                                (map { /$search/ ? ($1) : () } keys %sub)
  2616.     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
  2617.   return sort grep /^\Q$text/, values %INC # files
  2618.     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
  2619.   return sort map {($_, db_complete($_ . "::", "V ", 2))}
  2620.     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
  2621.       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
  2622.   return sort map {($_, db_complete($_ . "::", "V ", 2))}
  2623.     grep !/^main::/,
  2624.       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
  2625.                  # packages
  2626.     if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ 
  2627.       and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
  2628.   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
  2629.     # We may want to complete to (eval 9), so $text may be wrong
  2630.     $prefix = length($1) - length($text);
  2631.     $text = $1;
  2632.     return sort 
  2633.     map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
  2634.   }
  2635.   if ((substr $text, 0, 1) eq '&') { # subroutines
  2636.     $text = substr $text, 1;
  2637.     $prefix = "&";
  2638.     return sort map "$prefix$_", 
  2639.                grep /^\Q$text/, 
  2640.                  (keys %sub),
  2641.                  (map { /$search/ ? ($1) : () } 
  2642.             keys %sub);
  2643.   }
  2644.   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
  2645.     $pack = ($1 eq 'main' ? '' : $1) . '::';
  2646.     $prefix = (substr $text, 0, 1) . $1 . '::';
  2647.     $text = $2;
  2648.     my @out 
  2649.       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
  2650.     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
  2651.       return db_complete($out[0], $line, $start);
  2652.     }
  2653.     return sort @out;
  2654.   }
  2655.   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
  2656.     $pack = ($package eq 'main' ? '' : $package) . '::';
  2657.     $prefix = substr $text, 0, 1;
  2658.     $text = substr $text, 1;
  2659.     my @out = map "$prefix$_", grep /^\Q$text/, 
  2660.        (grep /^_?[a-zA-Z]/, keys %$pack), 
  2661.        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
  2662.     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
  2663.       return db_complete($out[0], $line, $start);
  2664.     }
  2665.     return sort @out;
  2666.   }
  2667.   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
  2668.     my @out = grep /^\Q$text/, @options;
  2669.     my $val = option_val($out[0], undef);
  2670.     my $out = '? ';
  2671.     if (not defined $val or $val =~ /[\n\r]/) {
  2672.       # Can do nothing better
  2673.     } elsif ($val =~ /\s/) {
  2674.       my $found;
  2675.       foreach $l (split //, qq/\"\'\#\|/) {
  2676.     $out = "$l$val$l ", last if (index $val, $l) == -1;
  2677.       }
  2678.     } else {
  2679.       $out = "=$val ";
  2680.     }
  2681.     # Default to value if one completion, to question if many
  2682.     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
  2683.     return sort @out;
  2684.   }
  2685.   return $term->filename_list($text); # filenames
  2686. }
  2687.  
  2688. sub end_report {
  2689.   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
  2690. }
  2691.  
  2692. END {
  2693.   $finished = 1 if $inhibit_exit;      # So that some keys may be disabled.
  2694.   $fall_off_end = 1 unless $inhibit_exit;
  2695.   # Do not stop in at_exit() and destructors on exit:
  2696.   $DB::single = !$fall_off_end && !$runnonstop;
  2697.   DB::fake::at_exit() unless $fall_off_end or $runnonstop;
  2698. }
  2699.  
  2700. package DB::fake;
  2701.  
  2702. sub at_exit {
  2703.   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
  2704. }
  2705.  
  2706. package DB;            # Do not trace this 1; below!
  2707.  
  2708. 1;
  2709.